core
/
eccodes
mirror of https://github.com/ecmwf/eccodes.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'develop' into feature/Template4refactoring

This commit is contained in:
Shahram Najm 2021-02-18 16:25:44 +00:00
parent d0c3e7d458 189de0025f
commit bc33269b52
92 changed files with 5882 additions and 5731 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
definitions/Makefile.am
View File

@ -14041,7 +14041,6 @@ dist_definitionsgrib2_DATA = \
grib2/template.7.6.def\
grib2/template.7.61.def\
grib2/template.7.second_order.def\
grib2/template.second_order.def\
grib2/tiggeLocalVersion.table\
grib2/tigge_name.def\
grib2/tigge_parameter.def\

16
definitions/add_params_from_tsv.pl
View File

@ -22,11 +22,11 @@
# parameterNumber
# # The following are optional keys
# typeOfFirstFixedSurface
# typeOfSecondFixedSurface
# scaledValueOfFirstFixedSurface
# scaleFactorOfFirstFixedSurface
# scaledValueOfSecondFixedSurface
# scaledValueOfFirstFixedSurface
# typeOfSecondFixedSurface
# scaleFactorOfSecondFixedSurface
# scaledValueOfSecondFixedSurface
# typeOfStatisticalProcessing
#
# It outputs the def files:
@ -57,6 +57,7 @@ write_or_append(\*OUT_CFVARNAME, "$CFVARNAME_FILENAME");
my $first = 1;
while (<>) {
chomp;
s/\r//g; # Remove DOS carriage returns
if ($first == 1) {
check_first_row_column_names($_);
$first = 0;
@ -124,13 +125,12 @@ sub check_first_row_column_names {
die "Error: 1st row column titles wrong: Column 7 should be 'parameterNumber'\n" if ($keys[6] ne "parameterNumber");
die "Error: 1st row column titles wrong: Column 8 should be 'typeOfFirstFixedSurface'\n" if ($keys[7] ne "typeOfFirstFixedSurface");
die "Error: 1st row column titles wrong: Column 9 should be 'typeOfSecondFixedSurface'\n" if ($keys[8] ne "typeOfSecondFixedSurface");
die "Error: 1st row column titles wrong: Column 9 should be 'scaleFactorOfFirstFixedSurface'\n" if ($keys[8] ne "scaleFactorOfFirstFixedSurface");
die "Error: 1st row column titles wrong: Column 10 should be 'scaledValueOfFirstFixedSurface'\n" if ($keys[9] ne "scaledValueOfFirstFixedSurface");
die "Error: 1st row column titles wrong: Column 11 should be 'scaleFactorOfFirstFixedSurface'\n" if ($keys[10] ne "scaleFactorOfFirstFixedSurface");
die "Error: 1st row column titles wrong: Column 12 should be 'scaledValueOfSecondFixedSurface'\n" if ($keys[11] ne "scaledValueOfSecondFixedSurface");
die "Error: 1st row column titles wrong: Column 13 should be 'scaleFactorOfSecondFixedSurface'\n" if ($keys[12] ne "scaleFactorOfSecondFixedSurface");
die "Error: 1st row column titles wrong: Column 11 should be 'typeOfSecondFixedSurface'\n" if ($keys[10] ne "typeOfSecondFixedSurface");
die "Error: 1st row column titles wrong: Column 12 should be 'scaleFactorOfSecondFixedSurface'\n" if ($keys[11] ne "scaleFactorOfSecondFixedSurface");
die "Error: 1st row column titles wrong: Column 13 should be 'scaledValueOfSecondFixedSurface'\n" if ($keys[12] ne "scaledValueOfSecondFixedSurface");
die "Error: 1st row column titles wrong: Column 14 should be 'typeOfStatisticalProcessing'\n" if ($keys[13] ne "typeOfStatisticalProcessing");
}

33
definitions/grib1/localConcepts/ecmf/typeOfLevel.def
View File

@ -1,37 +1,4 @@
# ECMWF concept type of level
'surface' = {indicatorOfTypeOfLevel=1;}
'cloudBase' = {indicatorOfTypeOfLevel=2;}
'cloudTop' = {indicatorOfTypeOfLevel=3;}
'isothermZero' = {indicatorOfTypeOfLevel=4;}
'adiabaticCondensation' = {indicatorOfTypeOfLevel=5;}
'maxWind' = {indicatorOfTypeOfLevel=6;}
'tropopause' = {indicatorOfTypeOfLevel=7;}
'nominalTop' = {indicatorOfTypeOfLevel=8;}
'seaBottom' = {indicatorOfTypeOfLevel=9;}
'isobaricInhPa' = {indicatorOfTypeOfLevel=100;}
'isobaricInPa' = {indicatorOfTypeOfLevel=210;}
'isobaricLayer' = {indicatorOfTypeOfLevel=101;}
'meanSea' = {indicatorOfTypeOfLevel=102;}
'isobaricLayerHighPrecision' = {indicatorOfTypeOfLevel=121;}
'isobaricLayerMixedPrecision' = {indicatorOfTypeOfLevel=141;}
'heightAboveSea' = {indicatorOfTypeOfLevel=103;}
'heightAboveSeaLayer' = {indicatorOfTypeOfLevel=104;}
'heightAboveGroundHighPrecision' = {indicatorOfTypeOfLevel=125;}
'heightAboveGround' = {indicatorOfTypeOfLevel=105;}
'heightAboveGroundLayer' = {indicatorOfTypeOfLevel=106;}
'sigma' = {indicatorOfTypeOfLevel=107;}
'sigmaLayer' = {indicatorOfTypeOfLevel=108;}
'sigmaLayerHighPrecision' = {indicatorOfTypeOfLevel=128;}
'hybrid' = {indicatorOfTypeOfLevel=109;}
'hybridLayer' = {indicatorOfTypeOfLevel=110;}
'depthBelowLand' = {indicatorOfTypeOfLevel=111;}
'depthBelowLandLayer' = {indicatorOfTypeOfLevel=112;}
'theta' = {indicatorOfTypeOfLevel=113;}
'thetaLayer' = {indicatorOfTypeOfLevel=114;}
'pressureFromGround' = {indicatorOfTypeOfLevel=115;}
'pressureFromGroundLayer' = {indicatorOfTypeOfLevel=116;}
'potentialVorticity' = {indicatorOfTypeOfLevel=117;}
'depthBelowSea' = {indicatorOfTypeOfLevel=160;}
'entireAtmosphere' = {indicatorOfTypeOfLevel=200;level=0;}
'entireOcean' = {indicatorOfTypeOfLevel=201;level=0;}
'oceanWave' = {indicatorOfTypeOfLevel=211;}

33
definitions/grib2/localConcepts/kwbc/typeOfLevelConcept.def Normal file
View File

@ -0,0 +1,33 @@
# Concept typeOfLevel for kwbc
'atmosphereSingleLayer' = {typeOfFirstFixedSurface=200;}
'oceanSingleLayer' = {typeOfFirstFixedSurface=201;}
'highestTroposphericFreezing' = {typeOfFirstFixedSurface=204;}
'gridScaleCloudBottom' = {typeOfFirstFixedSurface=206;}
'gridScaleCloudTop' = {typeOfFirstFixedSurface=207;}
'boundaryLayerCloudBottom' = {typeOfFirstFixedSurface=209;}
'boundaryLayerCloudTop' = {typeOfFirstFixedSurface=210;}
'boundaryLayerCloudLayer' = {typeOfFirstFixedSurface=211;}
'lowCloudBottom' = {typeOfFirstFixedSurface=212;}
'lowCloudTop' = {typeOfFirstFixedSurface=213;}
'lowCloudLayer' = {typeOfFirstFixedSurface=214;}
'cloudCeiling' = {typeOfFirstFixedSurface=215;}
'planetaryBoundaryLayer' = {typeOfFirstFixedSurface=220;}
'layerBetween2Hybrids' = {typeOfFirstFixedSurface=221;}
'middleCloudBottom' = {typeOfFirstFixedSurface=222;}
'middleCloudTop' = {typeOfFirstFixedSurface=223;}
'middleCloudLayer' = {typeOfFirstFixedSurface=224;}
'highCloudBottom' = {typeOfFirstFixedSurface=232;}
'highCloudTop' = {typeOfFirstFixedSurface=233;}
'highCloudLayer' = {typeOfFirstFixedSurface=234;}
'oceanIsotherm' = {typeOfFirstFixedSurface=235;}
'oceanMixedLayer' = {typeOfFirstFixedSurface=240;}
'orderedSequenceData' = {typeOfFirstFixedSurface=241;}
'convectiveCloudBottom' = {typeOfFirstFixedSurface=242;}
'convectiveCloudTop' = {typeOfFirstFixedSurface=243;}
'convectiveCloudLayer' = {typeOfFirstFixedSurface=244;}
'lowestLevelWetBulb0' = {typeOfFirstFixedSurface=245;}
'equilibrium' = {typeOfFirstFixedSurface=247;}
'shallowConvectiveCloudBottom' = {typeOfFirstFixedSurface=248;}
'shallowConvectiveCloudTop' = {typeOfFirstFixedSurface=249;}
'deepConvectiveCloudBottom' = {typeOfFirstFixedSurface=251;}
'deepConvectiveCloudTop' = {typeOfFirstFixedSurface=252;}

23
definitions/grib2/tables/local/kwbc/1/4.5.table
View File

@ -71,19 +71,42 @@
# 192-254 Reserved for local use
# See ECC-469
200 200 Entire atmosphere (considered as a single layer)
201 201 Entire ocean (considered as a single layer)
204 204 Highest tropospheric freezing level
206 206 Grid scale cloud bottom level
207 207 Grid scale cloud top level
209 209 Boundary layer cloud bottom level
210 210 Boundary layer cloud top level
211 211 Boundary layer cloud layer
212 212 Low cloud bottom level
213 213 Low cloud top level
214 214 Low cloud layer
215 215 Cloud ceiling
220 220 Planetary boundary layer
221 221 Layer between two hybrid levels
222 222 Middle cloud bottom level
223 223 Middle cloud top level
224 224 Middle cloud layer
232 232 High cloud bottom level
233 233 High cloud top level
234 234 High cloud layer
235 235 Ocean isotherm level (1/10 deg C)
236 236 Layer between two depths below ocean surface
237 237 Bottom of ocean mixed layer
238 238 Bottom of ocean isothermal layer
239 239 Layer ocean surface and 26C ocean isothermal level
240 240 Ocean mixed layer
241 241 Ordered sequence of data
242 242 Convective cloud bottom level
243 243 Convective cloud top level
244 244 Convective cloud layer
245 245 Lowest level of the wet bulb zero
246 246 Maximum equivalent potential temperature level
247 247 Equilibrium level
248 248 Shallow convective cloud bottom level
249 249 Shallow convective cloud top level
251 251 Deep convective cloud bottom level
252 252 Deep convective cloud top level
253 253 Lowest bottom level of supercooled liquid water layer
254 254 Highest top level of supercooled liquid water layer
255 255 Missing

2
definitions/grib2/template.5.4.def
View File

@ -3,7 +3,7 @@
# TEMPLATE 5.4, Grid point data - IEEE packing
# added for conversion from other packing
transient bitsPerValue=0 : hidden;
transient referenceValue=0 : hidden;
transient referenceValue=0 : hidden;
transient binaryScaleFactor=0 : hidden;
transient decimalScaleFactor=0 : hidden;
alias numberOfBits = bitsPerValue;

19
definitions/grib2/template.7.4.def
View File

@ -1,24 +1,21 @@
# (C) Copyright 2005- ECMWF.
# TEMPLATE 7.4, Grid point data - simple packing
# Octets 6-nn : Binary data values - binary string, with each
# (scaled)
# ???? data_values__binary_string_with_each
# TEMPLATE 7.4, Grid point data - IEEE floating point data
meta codedValues data_raw_packing(
meta codedValues data_raw_packing(
section7Length,
offsetBeforeData,
offsetSection7,
numberOfValues,
precision
): read_only;
): read_only;
meta values data_apply_bitmap(codedValues,
bitmap,
missingValue,
binaryScaleFactor,
numberOfDataPoints,
numberOfValues) : dump;
bitmap,
missingValue,
binaryScaleFactor,
numberOfDataPoints,
numberOfValues) : dump;
alias data.packedValues = codedValues;

1
definitions/grib2/template.second_order.def
View File

@ -1 +0,0 @@
#TODO

15
examples/C/grib_iterator.c
View File

@ -12,7 +12,6 @@
* C Implementation: grib_iterator
*
* Description: how to use an iterator on lat/lon/values for GRIB messages
*
*/
#include <stdio.h>
@ -33,6 +32,7 @@ int main(int argc, char** argv)
double lat, lon, value;
double missingValue = 1e+20; /* A value out of range */
int n = 0;
long bitmapPresent = 0;
char* filename = NULL;
/* Message handle. Required in all the ecCodes calls acting on a message.*/
@ -55,9 +55,14 @@ int main(int argc, char** argv)
/* Check of errors after reading a message. */
if (err != CODES_SUCCESS) CODES_CHECK(err, 0);
/* Set the double representing the missing value in the field. */
/* Choose a missingValue that does not correspond to any real value in the data array */
CODES_CHECK(codes_set_double(h, "missingValue", missingValue), 0);
/* Check if a bitmap applies */
CODES_CHECK(codes_get_long(h, "bitmapPresent", &bitmapPresent), 0);
if (bitmapPresent) {
/* Set the double representing the missing value in the field. */
/* Choose a missingValue that does not correspond to any real value in the data array */
CODES_CHECK(codes_set_double(h, "missingValue", missingValue), 0);
}
/* A new iterator on lat/lon/values is created from the message handle h. */
iter = codes_grib_iterator_new(h, 0, &err);
@ -69,7 +74,7 @@ int main(int argc, char** argv)
/* You can now print lat and lon, */
printf("- %d - lat=%f lon=%f value=", n, lat, lon);
/* decide what to print if a missing value is found. */
if (value == missingValue) printf("missing\n");
if (bitmapPresent && value == missingValue) printf("missing\n");
/* and print the value if is not missing. */
else
printf("%f\n", value);

9
examples/C/grib_iterator.sh
View File

@ -8,8 +8,15 @@
# virtue of its status as an intergovernmental organisation nor does it submit to any jurisdiction.
. ./include.sh
temp=temp.c_grib_iterator.txt
# These two do not have any missing data
${examples_dir}/c_grib_iterator ${data_dir}/reduced_gaussian_model_level.grib1 > /dev/null
${examples_dir}/c_grib_iterator ${data_dir}/regular_gaussian_model_level.grib1 > /dev/null
# Has missing data
${examples_dir}/c_grib_iterator ${data_dir}/reduced_latlon_surface.grib2 > $temp
count_miss=`grep -c missing $temp`
[ $count_miss = 98701 ]
rm -f $temp

141
examples/F90/bufr_attributes.f90
View File

@ -13,101 +13,100 @@
!
!
program bufr_attributes
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: count=0
integer(kind=4) :: iVal,conf
real(kind=8) :: t2m
character(len=32) :: units, confUnits
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: count = 0
integer(kind=4) :: iVal, conf
real(kind=8) :: t2m
character(len=32) :: units, confUnits
call codes_open_file(ifile,'../../data/bufr/syno_multi.bufr','r')
call codes_open_file(ifile, '../../data/bufr/syno_multi.bufr', 'r')
! the first bufr message is loaded from file
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
call codes_bufr_new_from_file(ifile, ibufr, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
! Get and print some keys form the BUFR header
write(*,*) 'message: ',count
! Get and print some keys form the BUFR header
write (*, *) 'message: ', count
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr,"unpack",1);
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr, "unpack", 1);
! ----------------------------------------------------------------
! We will read the value and all the attributes available for
! the 2m temperature.
! ----------------------------------------------------------------
! ----------------------------------------------------------------
! We will read the value and all the attributes available for
! the 2m temperature.
! ----------------------------------------------------------------
! Get the element's value as as real
call codes_get(ibufr, 'airTemperatureAt2M', t2m);
write (*, *) ' airTemperatureAt2M:', t2m
! Get the element's value as as real
call codes_get(ibufr,'airTemperatureAt2M',t2m);
write(*,*) ' airTemperatureAt2M:',t2m
! Get the element's code (see BUFR code table B)
call codes_get(ibufr, 'airTemperatureAt2M->code', iVal);
write (*, *) ' airTemperatureAt2M->code:', iVal
! Get the element's code (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->code',iVal);
write(*,*) ' airTemperatureAt2M->code:',iVal
! Get the element's units (see BUFR code table B)
call codes_get(ibufr, 'airTemperatureAt2M->units', units)
write (*, *) ' airTemperatureAt2M->units:', units
! Get the element's units (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->units',units)
write(*,*) ' airTemperatureAt2M->units:',units
! Get the element's scale (see BUFR code table B)
call codes_get(ibufr, 'airTemperatureAt2M->scale', iVal);
write (*, *) ' airTemperatureAt2M->code:', iVal
! Get the element's scale (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->scale',iVal);
write(*,*) ' airTemperatureAt2M->code:',iVal
! Get the element's reference (see BUFR code table B)
call codes_get(ibufr, 'airTemperatureAt2M->reference', iVal);
write (*, *) ' airTemperatureAt2M->reference:', iVal
! Get the element's reference (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->reference',iVal);
write(*,*) ' airTemperatureAt2M->reference:',iVal
! Get the element's width (see BUFR code table B)
call codes_get(ibufr, 'airTemperatureAt2M->width', iVal);
write (*, *) ' airTemperatureAt2M->width:', iVal
! Get the element's width (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->width',iVal);
write(*,*) ' airTemperatureAt2M->width:',iVal
! -------------------------------------------------------------------
! The 2m temperature data element in this message has an associated
! field: percentConfidence. Its value and attributes can be accessed
! in a similar manner as was shown above for 2m temperature.
! -------------------------------------------------------------------
! -------------------------------------------------------------------
! The 2m temperature data element in this message has an associated
! field: percentConfidence. Its value and attributes can be accessed
! in a similar manner as was shown above for 2m temperature.
! -------------------------------------------------------------------
! Get the element's value as as real
call codes_get(ibufr, 'airTemperatureAt2M->percentConfidence', conf);
write (*, *) ' airTemperatureAt2M->percentConfidence:', conf
! Get the element's value as as real
call codes_get(ibufr,'airTemperatureAt2M->percentConfidence',conf);
write(*,*) ' airTemperatureAt2M->percentConfidence:', conf
! Get the element's code (see BUFR code table B)
call codes_get(ibufr, 'airTemperatureAt2M->percentConfidence->code', iVal);
write (*, *) ' airTemperatureAt2M->percentConfidence->code:', iVal
! Get the element's code (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->percentConfidence->code',iVal);
write(*,*) ' airTemperatureAt2M->percentConfidence->code:',iVal
! Get the element's units (see BUFR code table B)
call codes_get(ibufr, 'airTemperatureAt2M->percentConfidence->units', confUnits)
write (*, *) ' airTemperatureAt2M->percentConfidence->units:', confUnits
! Get the element's units (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->percentConfidence->units',confUnits)
write(*,*) ' airTemperatureAt2M->percentConfidence->units:',confUnits
! Get the element's scale (see BUFR code table B)
call codes_get(ibufr, 'airTemperatureAt2M->percentConfidence->scale', iVal);
write (*, *) ' airTemperatureAt2M->percentConfidence->code:', iVal
! Get the element's scale (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->percentConfidence->scale',iVal);
write(*,*) ' airTemperatureAt2M->percentConfidence->code:',iVal
! Get the element's reference (see BUFR code table B)
call codes_get(ibufr, 'airTemperatureAt2M->percentConfidence->reference', iVal);
write (*, *) ' airTemperatureAt2M->percentConfidence->reference:', iVal
! Get the element's reference (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->percentConfidence->reference',iVal);
write(*,*) ' airTemperatureAt2M->percentConfidence->reference:',iVal
! Get the element's width (see BUFR code table B)
call codes_get(ibufr, 'airTemperatureAt2M->percentConfidence->width', iVal);
write (*, *) ' airTemperatureAt2M->percentConfidence->width:', iVal
! Get the element's width (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->percentConfidence->width',iVal);
write(*,*) ' airTemperatureAt2M->percentConfidence->width:',iVal
! Release the bufr message
call codes_release(ibufr)
! Release the bufr message
call codes_release(ibufr)
! Load the next bufr message
call codes_bufr_new_from_file(ifile, ibufr, iret)
! Load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
count = count + 1
count=count+1
end do
end do
! Close file
call codes_close_file(ifile)
! Close file
call codes_close_file(ifile)
end program bufr_attributes

60
examples/F90/bufr_clone.f90
View File

@ -13,45 +13,45 @@
!
!
program bufr_clone
use eccodes
implicit none
integer :: i,iret
integer :: infile,outfile
integer :: ibufr_in
integer :: ibufr_out
use eccodes
implicit none
integer :: i, iret
integer :: infile, outfile
integer :: ibufr_in
integer :: ibufr_out
! Open source file
call codes_open_file(infile,'../../data/bufr/syno_multi.bufr','r')
! Open source file
call codes_open_file(infile, '../../data/bufr/syno_multi.bufr', 'r')
! Open target file
call codes_open_file(outfile,'bufr_clone_test_f.clone.bufr','w')
! Open target file
call codes_open_file(outfile, 'bufr_clone_test_f.clone.bufr', 'w')
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(infile,ibufr_in,iret)
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(infile, ibufr_in, iret)
! Create several clones of this message and alter them
! in different ways
do i=1,3
! Create several clones of this message and alter them
! in different ways
do i = 1, 3
! Clone the current handle
call codes_clone(ibufr_in, ibufr_out)
! Clone the current handle
call codes_clone(ibufr_in, ibufr_out)
! This is the place where you may wish to modify the clone
! E.g. we change the bufrHeaderCentre
call codes_set(ibufr_out,'bufrHeaderCentre',222)
! This is the place where you may wish to modify the clone
! E.g. we change the bufrHeaderCentre
call codes_set(ibufr_out, 'bufrHeaderCentre', 222)
! Write cloned messages to a file
call codes_write(ibufr_out,outfile)
! Write cloned messages to a file
call codes_write(ibufr_out, outfile)
! Release the clone's handle
call codes_release(ibufr_out)
end do
! Release the clone's handle
call codes_release(ibufr_out)
end do
! Release the original handle
call codes_release(ibufr_in)
! Release the original handle
call codes_release(ibufr_in)
call codes_close_file(infile)
call codes_close_file(outfile)
call codes_close_file(infile)
call codes_close_file(outfile)
end program bufr_clone

126
examples/F90/bufr_copy_data.f90
View File

@ -15,72 +15,72 @@
!
program bufr_encode
use eccodes
implicit none
integer :: iret
integer :: outfile
integer :: ifile
integer :: ibufr
integer :: ibufrin
integer(kind=4), dimension(:), allocatable :: ivalues
integer, parameter :: max_strsize = 200
character(len=max_strsize) :: infile_name
character(len=max_strsize) :: outfile_name
use eccodes
implicit none
integer :: iret
integer :: outfile
integer :: ifile
integer :: ibufr
integer :: ibufrin
integer(kind=4), dimension(:), allocatable :: ivalues
integer, parameter :: max_strsize = 200
character(len=max_strsize) :: infile_name
character(len=max_strsize) :: outfile_name
call codes_bufr_new_from_samples(ibufr,'BUFR3',iret)
call getarg(1, infile_name)
call getarg(2, outfile_name)
call codes_open_file(ifile, infile_name, 'r')
call codes_bufr_new_from_file(ifile, ibufrin)
call codes_bufr_new_from_samples(ibufr, 'BUFR3', iret)
call getarg(1, infile_name)
call getarg(2, outfile_name)
call codes_open_file(ifile, infile_name, 'r')
call codes_bufr_new_from_file(ifile, ibufrin)
if (iret/=CODES_SUCCESS) then
print *,'ERROR creating BUFR from BUFR3'
stop 1
endif
if(allocated(ivalues)) deallocate(ivalues)
allocate(ivalues(69))
ivalues=(/ &
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
0, 0, 0, 1, 1, 1, 1, 1, 1, 1, &
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, &
1, 1, 1, 1, 1, 0, 1, 1, 1, 1, &
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, &
1, 1, 1, 1, 1, 1, 1, 1, 0 /)
call codes_set(ibufr,'inputDataPresentIndicator',ivalues)
call codes_set(ibufr,'edition',3)
call codes_set(ibufr,'masterTableNumber',0)
call codes_set(ibufr,'bufrHeaderSubCentre',0)
call codes_set(ibufr,'bufrHeaderCentre',98)
call codes_set(ibufr,'updateSequenceNumber',1)
call codes_set(ibufr,'dataCategory',0)
call codes_set(ibufr,'dataSubCategory',140)
call codes_set(ibufr,'masterTablesVersionNumber',13)
call codes_set(ibufr,'localTablesVersionNumber',1)
call codes_set(ibufr,'typicalYearOfCentury',15)
call codes_set(ibufr,'typicalMonth',5)
call codes_set(ibufr,'typicalDay',4)
call codes_set(ibufr,'typicalHour',9)
call codes_set(ibufr,'typicalMinute',30)
call codes_set(ibufr,'numberOfSubsets',1)
call codes_set(ibufr,'observedData',1)
call codes_set(ibufr,'compressedData',0)
if(allocated(ivalues)) deallocate(ivalues)
allocate(ivalues(43))
ivalues=(/ &
307011,7006,10004,222000,101023,31031,1031,1032,101023,33007, &
225000,236000,101023,31031,1031,1032,8024,101001,225255,225000, &
236000,101023,31031,1031,1032,8024,101001,225255, &
1063,2001,4001,4002,4003,4004,4005,5002, &
6002,7001,7006,11001,11016,11017,11002 /)
call codes_set(ibufr,'unexpandedDescriptors',ivalues)
if (iret /= CODES_SUCCESS) then
print *, 'ERROR creating BUFR from BUFR3'
stop 1
end if
if (allocated(ivalues)) deallocate (ivalues)
allocate (ivalues(69))
ivalues = (/ &
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
0, 0, 0, 1, 1, 1, 1, 1, 1, 1, &
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, &
1, 1, 1, 1, 1, 0, 1, 1, 1, 1, &
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, &
1, 1, 1, 1, 1, 1, 1, 1, 0/)
call codes_set(ibufr, 'inputDataPresentIndicator', ivalues)
call codes_set(ibufr, 'edition', 3)
call codes_set(ibufr, 'masterTableNumber', 0)
call codes_set(ibufr, 'bufrHeaderSubCentre', 0)
call codes_set(ibufr, 'bufrHeaderCentre', 98)
call codes_set(ibufr, 'updateSequenceNumber', 1)
call codes_set(ibufr, 'dataCategory', 0)
call codes_set(ibufr, 'dataSubCategory', 140)
call codes_set(ibufr, 'masterTablesVersionNumber', 13)
call codes_set(ibufr, 'localTablesVersionNumber', 1)
call codes_set(ibufr, 'typicalYearOfCentury', 15)
call codes_set(ibufr, 'typicalMonth', 5)
call codes_set(ibufr, 'typicalDay', 4)
call codes_set(ibufr, 'typicalHour', 9)
call codes_set(ibufr, 'typicalMinute', 30)
call codes_set(ibufr, 'numberOfSubsets', 1)
call codes_set(ibufr, 'observedData', 1)
call codes_set(ibufr, 'compressedData', 0)
if (allocated(ivalues)) deallocate (ivalues)
allocate (ivalues(43))
ivalues = (/ &
307011, 7006, 10004, 222000, 101023, 31031, 1031, 1032, 101023, 33007, &
225000, 236000, 101023, 31031, 1031, 1032, 8024, 101001, 225255, 225000, &
236000, 101023, 31031, 1031, 1032, 8024, 101001, 225255, &
1063, 2001, 4001, 4002, 4003, 4004, 4005, 5002, &
6002, 7001, 7006, 11001, 11016, 11017, 11002/)
call codes_set(ibufr, 'unexpandedDescriptors', ivalues)
call codes_set(ibufrin,'unpack',1)
call codes_set(ibufrin, 'unpack', 1)
call codes_bufr_copy_data(ibufrin, ibufr)
call codes_bufr_copy_data(ibufrin, ibufr)
call codes_open_file(outfile,outfile_name,'w')
call codes_write(ibufr,outfile)
call codes_close_file(outfile)
call codes_release(ibufr)
call codes_open_file(outfile, outfile_name, 'w')
call codes_write(ibufr, outfile)
call codes_close_file(outfile)
call codes_release(ibufr)
end program bufr_encode

30
examples/F90/bufr_copy_keys.f90
View File

@ -9,26 +9,26 @@
! Description: how to copy a BUFR key from a message to another.
!
program bufr_copy_keys
use eccodes
implicit none
integer :: file1, file2, file3
integer :: ibufr1,ibufr2,ibufr3
use eccodes
implicit none
integer :: file1, file2, file3
integer :: ibufr1, ibufr2, ibufr3
call codes_open_file(file1, '../../data/bufr/PraticaTemp.bufr', 'r')
call codes_open_file(file2, '../../data/bufr/aaen_55.bufr', 'r')
call codes_open_file(file3, 'out.bufr_copy_keys_test_f.bufr', 'w')
call codes_open_file(file1, '../../data/bufr/PraticaTemp.bufr', 'r')
call codes_open_file(file2, '../../data/bufr/aaen_55.bufr', 'r')
call codes_open_file(file3, 'out.bufr_copy_keys_test_f.bufr', 'w')
call codes_bufr_new_from_file(file1, ibufr1)
call codes_bufr_new_from_file(file2, ibufr2)
call codes_bufr_new_from_file(file1, ibufr1)
call codes_bufr_new_from_file(file2, ibufr2)
call codes_clone(ibufr2, ibufr3)
call codes_clone(ibufr2, ibufr3)
call codes_copy_key(ibufr1, 'bufrHeaderCentre', ibufr3)
call codes_copy_key(ibufr1, 'bufrHeaderCentre', ibufr3)
call codes_write(ibufr3, file3)
call codes_write(ibufr3, file3)
call codes_close_file(file1)
call codes_close_file(file2)
call codes_close_file(file3)
call codes_close_file(file1)
call codes_close_file(file2)
call codes_close_file(file3)
end program bufr_copy_keys

58
examples/F90/bufr_copy_message.f90
View File

@ -11,43 +11,43 @@
!
!
program copy
use eccodes
implicit none
integer :: err, sub_centre
integer(kind=kindOfSize) :: byte_size
integer :: infile,outfile
integer :: ibufr_in
integer :: ibufr_out
character(len=1), dimension(:), allocatable :: message
character(len=32) :: product_kind
use eccodes
implicit none
integer :: err, sub_centre
integer(kind=kindOfSize) :: byte_size
integer :: infile, outfile
integer :: ibufr_in
integer :: ibufr_out
character(len=1), dimension(:), allocatable :: message
character(len=32) :: product_kind
call codes_open_file(infile,'../../data/bufr/syno_1.bufr', 'r')
call codes_open_file(outfile,'out.copy.bufr', 'w')
call codes_open_file(infile, '../../data/bufr/syno_1.bufr', 'r')
call codes_open_file(outfile, 'out.copy.bufr', 'w')
! A new BUFR message is loaded from file,
! ibufr_in is the BUFR id to be used in subsequent calls
call codes_bufr_new_from_file(infile, ibufr_in)
! A new BUFR message is loaded from file,
! ibufr_in is the BUFR id to be used in subsequent calls
call codes_bufr_new_from_file(infile, ibufr_in)
call codes_get_message_size(ibufr_in, byte_size)
allocate(message(byte_size), stat=err)
call codes_get_message_size(ibufr_in, byte_size)
allocate (message(byte_size), stat=err)
call codes_copy_message(ibufr_in, message)
call codes_copy_message(ibufr_in, message)
call codes_new_from_message(ibufr_out, message)
call codes_new_from_message(ibufr_out, message)
call codes_get(ibufr_out, 'kindOfProduct', product_kind)
write(*,*) 'kindOfProduct=',product_kind
call codes_get(ibufr_out, 'kindOfProduct', product_kind)
write (*, *) 'kindOfProduct=', product_kind
sub_centre=80
call codes_set(ibufr_out,'bufrHeaderSubCentre', sub_centre)
sub_centre = 80
call codes_set(ibufr_out, 'bufrHeaderSubCentre', sub_centre)
! Write message to a file
call codes_write(ibufr_out, outfile)
! Write message to a file
call codes_write(ibufr_out, outfile)
call codes_release(ibufr_out)
call codes_release(ibufr_in)
call codes_close_file(infile)
call codes_close_file(outfile)
deallocate(message)
call codes_release(ibufr_out)
call codes_release(ibufr_in)
call codes_close_file(infile)
call codes_close_file(outfile)
deallocate (message)
end program copy

69
examples/F90/bufr_expanded.f90
View File

@ -13,53 +13,52 @@
!
!
program bufr_expanded
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i
integer :: count=0
integer(kind=4) :: numberOfValues
real(kind=8), dimension(:), allocatable :: values
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i
integer :: count = 0
integer(kind=4) :: numberOfValues
real(kind=8), dimension(:), allocatable :: values
call codes_open_file(ifile,'../../data/bufr/syno_1.bufr','r')
call codes_open_file(ifile, '../../data/bufr/syno_1.bufr', 'r')
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile, ibufr, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
write(*,*) 'message: ',count
write (*, *) 'message: ', count
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr,"unpack",1);
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr, "unpack", 1);
! Get the expanded data values
call codes_get(ibufr, 'numericValues', values)
! Get the expanded data values
call codes_get(ibufr,'numericValues',values)
numberOfValues = size(values)
numberOfValues=size(values)
do i = 1, numberOfValues
write (*, *) ' ', i, values(i)
end do
do i=1,numberOfValues
write(*,*) ' ',i,values(i)
enddo
! Release the bufr message
call codes_release(ibufr)
! Release the bufr message
call codes_release(ibufr)
! Load the next bufr message
call codes_bufr_new_from_file(ifile, ibufr, iret)
! Load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
! Free array
deallocate (values)
! Free array
deallocate(values)
count = count + 1
count=count+1
end do
end do
! Close file
call codes_close_file(ifile)
! Close file
call codes_close_file(ifile)
end program bufr_expanded

119
examples/F90/bufr_get_keys.f90
View File

@ -13,86 +13,85 @@
!
!
program bufr_get_keys
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i, count=0
integer(kind=4) :: blockNumber,stationNumber
real(kind=8) :: t2m
integer(kind=4), dimension(:), allocatable :: descriptors
real(kind=8), dimension(:), allocatable :: values
character(len=9) :: typicalDate
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i, count = 0
integer(kind=4) :: blockNumber, stationNumber
real(kind=8) :: t2m
integer(kind=4), dimension(:), allocatable :: descriptors
real(kind=8), dimension(:), allocatable :: values
character(len=9) :: typicalDate
call codes_open_file(ifile,'../../data/bufr/syno_multi.bufr','r')
call codes_open_file(ifile, '../../data/bufr/syno_multi.bufr', 'r')
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile, ibufr, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
! Get and print some keys form the BUFR header
write(*,*) 'message: ',count
! Get and print some keys form the BUFR header
write (*, *) 'message: ', count
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr,"unpack",1);
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr, "unpack", 1);
! Get as character
call codes_get(ibufr, 'typicalDate', typicalDate)
write (*, *) ' typicalDate:', typicalDate
! Get as character
call codes_get(ibufr,'typicalDate',typicalDate)
write(*,*) ' typicalDate:',typicalDate
! Get as integer
call codes_get(ibufr, 'blockNumber', blockNumber);
write (*, *) ' blockNumber:', blockNumber
! Get as integer
call codes_get(ibufr,'blockNumber',blockNumber);
write(*,*) ' blockNumber:',blockNumber
! Get as integer
call codes_get(ibufr, 'stationNumber', stationNumber);
write (*, *) ' stationNumber:', stationNumber
! Get as integer
call codes_get(ibufr,'stationNumber',stationNumber);
write(*,*) ' stationNumber:',stationNumber
! get as real
call codes_get(ibufr, 'airTemperatureAt2M', t2m);
write (*, *) ' airTemperatureAt2M:', t2m
! get as real
call codes_get(ibufr,'airTemperatureAt2M',t2m);
write(*,*) ' airTemperatureAt2M:',t2m
! ---- array of integer ----------------
! ---- array of integer ----------------
! get the expanded descriptors
call codes_get(ibufr, 'bufrdcExpandedDescriptors', descriptors)
! get the expanded descriptors
call codes_get(ibufr,'bufrdcExpandedDescriptors',descriptors)
do i = 1, size(descriptors)
write (*, *) ' ', i, descriptors(i)
end do
do i=1,size(descriptors)
write(*,*) ' ',i,descriptors(i)
enddo
! ---- array of real ----------------
! ---- array of real ----------------
! Get the expanded data values
call codes_get(ibufr, 'numericValues', values)
! Get the expanded data values
call codes_get(ibufr,'numericValues',values)
do i = 1, size(values)
write (*, *) ' ', i, values(i)
end do
do i=1,size(values)
write(*,*) ' ',i,values(i)
enddo
! Get as character
call codes_get(ibufr, 'typicalDate', typicalDate)
write (*, *) ' typicalDate:', typicalDate
! Get as character
call codes_get(ibufr,'typicalDate',typicalDate)
write(*,*) ' typicalDate:',typicalDate
! Free arrays
deallocate (values)
deallocate (descriptors)
! Free arrays
deallocate(values)
deallocate(descriptors)
! Release the bufr message
call codes_release(ibufr)
! Release the bufr message
call codes_release(ibufr)
! Load the next bufr message
call codes_bufr_new_from_file(ifile, ibufr, iret)
! Load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
count = count + 1
count=count+1
end do
end do
! Close file
call codes_close_file(ifile)
! Close file
call codes_close_file(ifile)
end program bufr_get_keys

74
examples/F90/bufr_get_string_array.f90
View File

@ -12,53 +12,53 @@
! Description: how to get an array of strings from a BUFR message.
program bufr_get_string_array
use eccodes
implicit none
integer :: ifile
integer :: iret,i,n
integer :: ibufr
integer :: strsize
integer, parameter :: max_strsize = 20
character(len=max_strsize) , dimension(:),allocatable :: stationOrSiteName
use eccodes
implicit none
integer :: ifile
integer :: iret, i, n
integer :: ibufr
integer :: strsize
integer, parameter :: max_strsize = 20
character(len=max_strsize), dimension(:), allocatable :: stationOrSiteName
call codes_open_file(ifile,'../../data/bufr/pgps_110.bufr','r')
call codes_open_file(ifile, '../../data/bufr/pgps_110.bufr', 'r')
call codes_bufr_new_from_file(ifile,ibufr,iret)
call codes_bufr_new_from_file(ifile, ibufr, iret)
! Unpack the data values
call codes_set(ibufr,'unpack',1)
! Unpack the data values
call codes_set(ibufr, 'unpack', 1)
! Get the width of the strings which is the same for all of them
call codes_get(ibufr,'stationOrSiteName->width',strsize)
! Get the width of the strings which is the same for all of them
call codes_get(ibufr, 'stationOrSiteName->width', strsize)
! The width is given in bits
strsize=strsize/8
! The width is given in bits
strsize = strsize/8
! max_strsize has to be set to a value >= to the size of the strings that we are getting
! back from the call to codes_get_string_array
if (strsize > max_strsize) then
print *,'stationOrSiteName array dimension is ',max_strsize,' and should be ',strsize
call exit(1)
end if
! max_strsize has to be set to a value >= to the size of the strings that we are getting
! back from the call to codes_get_string_array
if (strsize > max_strsize) then
print *, 'stationOrSiteName array dimension is ', max_strsize, ' and should be ', strsize
call exit(1)
end if
! Allocating the array of strings to be passed to codes_get_string_array is mandatory
call codes_get_size(ibufr,'stationOrSiteName',n)
allocate(stationOrSiteName(n))
! Allocating the array of strings to be passed to codes_get_string_array is mandatory
call codes_get_size(ibufr, 'stationOrSiteName', n)
allocate (stationOrSiteName(n))
! Passing an array of strings stationOrSiteName which must be allocated beforehand
call codes_get_string_array(ibufr,'stationOrSiteName',stationOrSiteName)
do i=1,n
write(*,'(A)')trim(stationOrSiteName(i))
end do
! Passing an array of strings stationOrSiteName which must be allocated beforehand
call codes_get_string_array(ibufr, 'stationOrSiteName', stationOrSiteName)
do i = 1, n
write (*, '(A)') trim(stationOrSiteName(i))
end do
! Remember to deallocate
deallocate(stationOrSiteName)
! Remember to deallocate
deallocate (stationOrSiteName)
! Release memory associated with bufr handle
! ibufr won't be accessible after this
call codes_release(ibufr)
! Release memory associated with bufr handle
! ibufr won't be accessible after this
call codes_release(ibufr)
! Close file
call codes_close_file(ifile)
! Close file
call codes_close_file(ifile)
end program bufr_get_string_array

89
examples/F90/bufr_keys_iterator.f90
View File

@ -15,65 +15,64 @@
! keys in a BUFR message.
!
program bufr_keys_iterator
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: count=0
character(len=256) :: key
integer :: kiter
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: count = 0
character(len=256) :: key
integer :: kiter
call codes_open_file(ifile,'../../data/bufr/syno_1.bufr','r')
call codes_open_file(ifile, '../../data/bufr/syno_1.bufr', 'r')
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile, ibufr, iret)
do while (iret /= CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
! Get and print some keys form the BUFR header
write(*,*) 'message: ',count
! Get and print some keys form the BUFR header
write (*, *) 'message: ', count
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr,"unpack",1);
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr, "unpack", 1);
! Create BUFR keys iterator
call codes_bufr_keys_iterator_new(ibufr, kiter, iret)
! Create BUFR keys iterator
call codes_bufr_keys_iterator_new(ibufr,kiter,iret)
if (iret .ne. 0) then
write (*, *) 'ERROR: Unable to create BUFR keys iterator'
call exit(1)
end if
if (iret .ne. 0) then
write(*,*) 'ERROR: Unable to create BUFR keys iterator'
call exit(1)
end if
! Get first key
call codes_bufr_keys_iterator_next(kiter, iret)
! Get first key
call codes_bufr_keys_iterator_next(kiter, iret)
! Loop over keys
do while (iret == CODES_SUCCESS)
! Print key name
call codes_bufr_keys_iterator_get_name(kiter, key)
write (*, *) ' ', trim(key)
! Loop over keys
do while (iret == CODES_SUCCESS)
! Print key name
call codes_bufr_keys_iterator_get_name(kiter,key)
write(*,*) ' ',trim(key)
! Get next key
call codes_bufr_keys_iterator_next(kiter, iret)
end do
! Get next key
call codes_bufr_keys_iterator_next(kiter, iret)
end do
! Delete key iterator
call codes_bufr_keys_iterator_delete(kiter)
! Delete key iterator
call codes_bufr_keys_iterator_delete(kiter)
! Release the bufr message
call codes_release(ibufr)
! Release the bufr message
call codes_release(ibufr)
! Load the next bufr message
call codes_bufr_new_from_file(ifile, ibufr, iret)
! Load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
count = count + 1
count=count+1
end do
end do
! Close file
call codes_close_file(ifile)
! Close file
call codes_close_file(ifile)
end program bufr_keys_iterator

82
examples/F90/bufr_read_header.f90
View File

@ -13,63 +13,63 @@
!
!
program bufr_read_header
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: count=0
integer(kind=4) :: dataCategory,dataSubCategory,typicalDate
integer(kind=4) :: centre,subcentre
integer(kind=4) :: masterversion,localversion
integer(kind=4) :: numberOfSubsets
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: count = 0
integer(kind=4) :: dataCategory, dataSubCategory, typicalDate
integer(kind=4) :: centre, subcentre
integer(kind=4) :: masterversion, localversion
integer(kind=4) :: numberOfSubsets
call codes_open_file(ifile,'../../data/bufr/syno_multi.bufr','r')
call codes_open_file(ifile, '../../data/bufr/syno_multi.bufr', 'r')
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile, ibufr, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
! Get and print some keys form the BUFR header
write(*,*) 'message: ',count
! Get and print some keys form the BUFR header
write (*, *) 'message: ', count
call codes_get(ibufr,'dataCategory',dataCategory);
write(*,*) ' dataCategory:',dataCategory
call codes_get(ibufr, 'dataCategory', dataCategory);
write (*, *) ' dataCategory:', dataCategory
call codes_get(ibufr,'dataSubCategory',dataSubCategory);
write(*,*) ' dataSubCategory:',dataSubCategory
call codes_get(ibufr, 'dataSubCategory', dataSubCategory);
write (*, *) ' dataSubCategory:', dataSubCategory
call codes_get(ibufr,'typicalDate',typicalDate);
write(*,*) ' typicalDate:',typicalDate
call codes_get(ibufr, 'typicalDate', typicalDate);
write (*, *) ' typicalDate:', typicalDate
call codes_get(ibufr,'bufrHeaderCentre',centre);
write(*,*) ' bufrHeaderCentre:',centre
call codes_get(ibufr, 'bufrHeaderCentre', centre);
write (*, *) ' bufrHeaderCentre:', centre
call codes_get(ibufr,'bufrHeaderSubCentre',subcentre)
write(*,*) ' bufrHeaderSubCentre:',subcentre
call codes_get(ibufr, 'bufrHeaderSubCentre', subcentre)
write (*, *) ' bufrHeaderSubCentre:', subcentre
call codes_get(ibufr,'masterTablesVersionNumber',masterversion)
write(*,*) ' masterTablesVersionNumber:',masterversion
call codes_get(ibufr, 'masterTablesVersionNumber', masterversion)
write (*, *) ' masterTablesVersionNumber:', masterversion
call codes_get(ibufr,'localTablesVersionNumber',localversion)
write(*,*) ' localTablesVersionNumber:',localversion
call codes_get(ibufr, 'localTablesVersionNumber', localversion)
write (*, *) ' localTablesVersionNumber:', localversion
call codes_get(ibufr,'numberOfSubsets',numberOfSubsets)
write(*,*) ' numberOfSubsets:',numberOfSubsets
call codes_get(ibufr, 'numberOfSubsets', numberOfSubsets)
write (*, *) ' numberOfSubsets:', numberOfSubsets
! Release the bufr message
call codes_release(ibufr)
! Release the bufr message
call codes_release(ibufr)
! Load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
! Load the next bufr message
call codes_bufr_new_from_file(ifile, ibufr, iret)
count=count+1
count = count + 1
end do
end do
! Close file
call codes_close_file(ifile)
! Close file
call codes_close_file(ifile)
end program bufr_read_header

129
examples/F90/bufr_read_scatterometer.f90
View File

@ -15,90 +15,85 @@
! below might not work directly for other types of messages than the one used in the
! example. It is advised to use bufr_dump first to understand the structure of these messages.
program bufr_read_scatterometer
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i, count=0
integer(kind=4) :: numObs,ii
real(kind=8), dimension(:), allocatable :: latVal,lonVal,bscatterVal
real(kind=8), dimension(:), allocatable :: year
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i, count = 0
integer(kind=4) :: numObs, ii
real(kind=8), dimension(:), allocatable :: latVal, lonVal, bscatterVal
real(kind=8), dimension(:), allocatable :: year
call codes_open_file(ifile,'../../data/bufr/asca_139.bufr','r')
call codes_open_file(ifile, '../../data/bufr/asca_139.bufr', 'r')
! The first BUFR message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
! The first BUFR message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile, ibufr, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
write(*,'(A,I3)') 'message: ',count
write (*, '(A,I3)') 'message: ', count
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr,"unpack",1);
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr, "unpack", 1);
! The BUFR file contains a single message with 2016 subsets in a compressed form.
! It means each subset has exactly the same structure: they store one location with
! several beams and one backscatter value in each beam.
!
! To print the backScatter values for beamIdentifier=2 from all the subsets
! we will simply access the key by condition (see below).
! The BUFR file contains a single message with 2016 subsets in a compressed form.
! It means each subset has exactly the same structure: they store one location with
! several beams and one backscatter value in each beam.
!
! To print the backScatter values for beamIdentifier=2 from all the subsets
! we will simply access the key by condition (see below).
! Read the total number of subsets.
call codes_get(ibufr, 'numberOfSubsets', numObs)
! Read the total number of subsets.
call codes_get(ibufr,'numberOfSubsets',numObs)
write (*, '(A,I5)') "Number of values:", numObs
write(*,'(A,I5)') "Number of values:",numObs
! Get latitude (for all the subsets)
call codes_get(ibufr, 'latitude', latVal);
! Get longitude (for all the subsets)
call codes_get(ibufr, 'longitude', lonVal);
allocate (year(numObs))
call codes_get(ibufr, 'year', year);
do ii = 1, size(year)
write (*, '(A,I4,A,F8.1)') 'year(', ii, ')=', year(ii)
end do
! Get latitude (for all the subsets)
call codes_get(ibufr,'latitude',latVal);
! Get backScatter for beam two. We use an access by condition for this key.
! (for all the subsets)
call codes_get(ibufr, '/beamIdentifier=2/backscatter', bscatterVal);
! Check that all arrays are same size
if (size(latVal) /= numObs .or. size(lonVal) /= numObs .or. size(bscatterVal) /= numObs) then
print *, 'inconsistent array dimension'
exit
end if
! Get longitude (for all the subsets)
call codes_get(ibufr,'longitude',lonVal);
! Print the values
write (*, *) 'pixel lat lon backscatter'
write (*, *) "--------------------------------------"
allocate(year(numObs))
call codes_get(ibufr,'year',year);
do ii= 1, size(year)
write(*,'(A,I4,A,F8.1)') 'year(',ii,')=',year(ii)
enddo
do i = 1, numObs
write (*, '(I4,3F10.5)') i, latVal(i), lonVal(i), bscatterVal(i)
end do
! Get backScatter for beam two. We use an access by condition for this key.
! (for all the subsets)
call codes_get(ibufr,'/beamIdentifier=2/backscatter',bscatterVal);
! Free arrays
deallocate (latVal)
deallocate (lonVal)
deallocate (bscatterVal)
! Check that all arrays are same size
if (size(latVal)/= numObs .or. size(lonVal)/= numObs .or. size(bscatterVal)/= numObs) then
print *,'inconsistent array dimension'
exit
endif
! Release the bufr message
call codes_release(ibufr)
! Print the values
write(*,*) 'pixel lat lon backscatter'
write(*,*) "--------------------------------------"
! Load the next bufr message
call codes_bufr_new_from_file(ifile, ibufr, iret)
do i=1,numObs
write(*,'(I4,3F10.5)') i,latVal(i),lonVal(i),bscatterVal(i)
end do
count = count + 1
! Free arrays
deallocate(latVal)
deallocate(lonVal)
deallocate(bscatterVal)
end do
! Release the bufr message
call codes_release(ibufr)
! Load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
count=count+1
end do
! Close file
call codes_close_file(ifile)
! Close file
call codes_close_file(ifile)
end program bufr_read_scatterometer

144
examples/F90/bufr_read_synop.f90
View File

@ -18,102 +18,102 @@
!
!
program bufr_read_synop
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: count=0
integer(kind=4) :: blockNumber,stationNumber
real(kind=8) :: lat,t2m,td2m,ws,wdir
integer(kind=4) :: cloudAmount,cloudBaseHeight,lowCloud,midCloud,highCloud
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: count = 0
integer(kind=4) :: blockNumber, stationNumber
real(kind=8) :: lat, t2m, td2m, ws, wdir
integer(kind=4) :: cloudAmount, cloudBaseHeight, lowCloud, midCloud, highCloud
call codes_open_file(ifile,'../../data/bufr/syno_multi.bufr','r')
call codes_open_file(ifile, '../../data/bufr/syno_multi.bufr', 'r')
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile, ibufr, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
write(*,*) 'message: ',count
write (*, *) 'message: ', count
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr,"unpack",1)
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr, "unpack", 1)
!read and print some data values. This example was written
! for a SYNOP BUFR file!
!read and print some data values. This example was written
! for a SYNOP BUFR file!
! wmo block number
call codes_get(ibufr,'blockNumber',blockNumber)
write(*,*) ' blockNumber:',blockNumber
! wmo block number
call codes_get(ibufr, 'blockNumber', blockNumber)
write (*, *) ' blockNumber:', blockNumber
! station number
call codes_get(ibufr,'stationNumber',stationNumber)
write(*,*) ' stationNumber:',stationNumber
! station number
call codes_get(ibufr, 'stationNumber', stationNumber)
write (*, *) ' stationNumber:', stationNumber
! location
call codes_get(ibufr,'latitude',lat)
write(*,*) ' latitude:',lat
! location
call codes_get(ibufr, 'latitude', lat)
write (*, *) ' latitude:', lat
call codes_get(ibufr,'longitude',lat)
write(*,*) ' longitude:',lat
call codes_get(ibufr, 'longitude', lat)
write (*, *) ' longitude:', lat
! 2m temperature
call codes_get(ibufr,'airTemperatureAt2M',t2m);
write(*,*) ' airTemperatureAt2M:',t2m
! 2m temperature
call codes_get(ibufr, 'airTemperatureAt2M', t2m);
write (*, *) ' airTemperatureAt2M:', t2m
! 2m dewpoint temperature
call codes_get(ibufr,'dewpointTemperatureAt2M',td2m);
write(*,*) ' dewpointTemperatureAt2M:',td2m
! 2m dewpoint temperature
call codes_get(ibufr, 'dewpointTemperatureAt2M', td2m);
write (*, *) ' dewpointTemperatureAt2M:', td2m
! 10m wind
call codes_get(ibufr,'windSpeedAt10M',ws);
write(*,*) ' windSpeedAt10M:',ws
! 10m wind
call codes_get(ibufr, 'windSpeedAt10M', ws);
write (*, *) ' windSpeedAt10M:', ws
call codes_get(ibufr,'windDirectionAt10M',wdir);
write(*,*) ' windDirectionAt10M:',wdir
call codes_get(ibufr, 'windDirectionAt10M', wdir);
write (*, *) ' windDirectionAt10M:', wdir
! The cloud information is stored in several blocks in the
! SYNOP message and the same key means a different thing in different
! parts of the message. In this example we will read the first
! cloud block introduced by the key
! verticalSignificanceSurfaceObservations=1.
! We know that this is the first occurrence of the keys we want to
! read so we will use the # (occurrence) operator accordingly.
! The cloud information is stored in several blocks in the
! SYNOP message and the same key means a different thing in different
! parts of the message. In this example we will read the first
! cloud block introduced by the key
! verticalSignificanceSurfaceObservations=1.
! We know that this is the first occurrence of the keys we want to
! read so we will use the # (occurrence) operator accordingly.
! Cloud amount (low and middleclouds)
call codes_get(ibufr,'#1#cloudAmount',cloudAmount)
write(*,*) ' cloudAmount (low and middle):',cloudAmount
! Cloud amount (low and middleclouds)
call codes_get(ibufr, '#1#cloudAmount', cloudAmount)
write (*, *) ' cloudAmount (low and middle):', cloudAmount
! Height of cloud base
call codes_get(ibufr,'#1#heightOfBaseOfCloud',cloudBaseHeight)
write(*,*) ' heightOfBaseOfCloud:',cloudBaseHeight
! Height of cloud base
call codes_get(ibufr, '#1#heightOfBaseOfCloud', cloudBaseHeight)
write (*, *) ' heightOfBaseOfCloud:', cloudBaseHeight
! Cloud type (low clouds)
call codes_get(ibufr,'#1#cloudType',lowCloud)
write(*,*) ' cloudType (low):',lowCloud
! Cloud type (low clouds)
call codes_get(ibufr, '#1#cloudType', lowCloud)
write (*, *) ' cloudType (low):', lowCloud
! Cloud type (middle clouds)
call codes_get(ibufr,'#2#cloudType',midCloud)
write(*,*) ' cloudType (middle):',midCloud
! Cloud type (middle clouds)
call codes_get(ibufr, '#2#cloudType', midCloud)
write (*, *) ' cloudType (middle):', midCloud
! Cloud type (high clouds)
call codes_get(ibufr,'#3#cloudType',highCloud)
write(*,*) ' cloudType (high):',highCloud
! Cloud type (high clouds)
call codes_get(ibufr, '#3#cloudType', highCloud)
write (*, *) ' cloudType (high):', highCloud
! Release the bufr message
call codes_release(ibufr)
! Release the bufr message
call codes_release(ibufr)
! Load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
! Load the next bufr message
call codes_bufr_new_from_file(ifile, ibufr, iret)
count=count+1
count = count + 1
end do
end do
! Close file
call codes_close_file(ifile)
! Close file
call codes_close_file(ifile)
end program bufr_read_synop

114
examples/F90/bufr_read_temp.f90
View File

@ -16,64 +16,64 @@
! example. It is advised to use bufr_dump first to understand the structure of these messages.
!
program bufr_read_temp
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i, count=0
integer(kind=4),dimension(:), allocatable :: timePeriod,extendedVerticalSoundingSignificance
integer(kind=4) :: blockNumber,stationNumber
real(kind=8),dimension(:), allocatable :: pressure,airTemperature,dewpointTemperature
real(kind=8),dimension(:), allocatable :: geopotentialHeight,latitudeDisplacement,longitudeDisplacement
real(kind=8),dimension(:), allocatable :: windDirection,windSpeed
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i, count = 0
integer(kind=4), dimension(:), allocatable :: timePeriod, extendedVerticalSoundingSignificance
integer(kind=4) :: blockNumber, stationNumber
real(kind=8), dimension(:), allocatable :: pressure, airTemperature, dewpointTemperature
real(kind=8), dimension(:), allocatable :: geopotentialHeight, latitudeDisplacement, longitudeDisplacement
real(kind=8), dimension(:), allocatable :: windDirection, windSpeed
call codes_open_file(ifile,'../../data/bufr/PraticaTemp.bufr','r')
call codes_open_file(ifile, '../../data/bufr/PraticaTemp.bufr', 'r')
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
do while (iret/=CODES_END_OF_FILE)
write(*,*) 'message: ',count
call codes_set(ibufr,'unpack',1)
call codes_get(ibufr,'timePeriod',timePeriod)
call codes_get(ibufr,'pressure',pressure)
call codes_get(ibufr,'extendedVerticalSoundingSignificance',extendedVerticalSoundingSignificance)
call codes_get(ibufr,'nonCoordinateGeopotentialHeight',geopotentialHeight)
call codes_get(ibufr,'latitudeDisplacement',latitudeDisplacement)
call codes_get(ibufr,'longitudeDisplacement',longitudeDisplacement)
call codes_get(ibufr,'airTemperature',airTemperature)
call codes_get(ibufr,'dewpointTemperature',dewpointTemperature)
call codes_get(ibufr,'windDirection',windDirection)
call codes_get(ibufr,'windSpeed',windSpeed)
call codes_get(ibufr,'blockNumber',blockNumber)
call codes_get(ibufr,'stationNumber',stationNumber)
print *,'station',blockNumber,stationNumber
print *,'timePeriod pressure geopotentialHeight latitudeDisplacement &
&longitudeDisplacement airTemperature windDirection windSpeed significance'
do i=1,size(windSpeed)
write(*,'(I5,6X,F9.1,2X,F9.2,10X,F8.2,14X,F8.2,16X,F8.2,6X,F8.2,4X,F8.2,4X,I0)') timePeriod(i),pressure(i),&
&geopotentialHeight(i),latitudeDisplacement(i),&
&longitudeDisplacement(i),airTemperature(i),windDirection(i),windSpeed(i),extendedVerticalSoundingSignificance(i)
enddo
! Free arrays
deallocate(timePeriod)
deallocate(pressure)
deallocate(geopotentialHeight)
deallocate(latitudeDisplacement)
deallocate(longitudeDisplacement)
deallocate(airTemperature)
deallocate(dewpointTemperature)
deallocate(windDirection)
deallocate(windSpeed)
deallocate(extendedVerticalSoundingSignificance)
! Release the bufr message
call codes_release(ibufr)
! Load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
count=count+1
end do
! Close file
call codes_close_file(ifile)
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile, ibufr, iret)
do while (iret /= CODES_END_OF_FILE)
write (*, *) 'message: ', count
call codes_set(ibufr, 'unpack', 1)
call codes_get(ibufr, 'timePeriod', timePeriod)
call codes_get(ibufr, 'pressure', pressure)
call codes_get(ibufr, 'extendedVerticalSoundingSignificance', extendedVerticalSoundingSignificance)
call codes_get(ibufr, 'nonCoordinateGeopotentialHeight', geopotentialHeight)
call codes_get(ibufr, 'latitudeDisplacement', latitudeDisplacement)
call codes_get(ibufr, 'longitudeDisplacement', longitudeDisplacement)
call codes_get(ibufr, 'airTemperature', airTemperature)
call codes_get(ibufr, 'dewpointTemperature', dewpointTemperature)
call codes_get(ibufr, 'windDirection', windDirection)
call codes_get(ibufr, 'windSpeed', windSpeed)
call codes_get(ibufr, 'blockNumber', blockNumber)
call codes_get(ibufr, 'stationNumber', stationNumber)
print *, 'station', blockNumber, stationNumber
print *, 'timePeriod pressure geopotentialHeight latitudeDisplacement &
&longitudeDisplacement airTemperature windDirection windSpeed significance'
do i = 1, size(windSpeed)
write (*, '(I5,6X,F9.1,2X,F9.2,10X,F8.2,14X,F8.2,16X,F8.2,6X,F8.2,4X,F8.2,4X,I0)') timePeriod(i), pressure(i),&
&geopotentialHeight(i), latitudeDisplacement(i),&
&longitudeDisplacement(i), airTemperature(i), windDirection(i), windSpeed(i), extendedVerticalSoundingSignificance(i)
end do
! Free arrays
deallocate (timePeriod)
deallocate (pressure)
deallocate (geopotentialHeight)
deallocate (latitudeDisplacement)
deallocate (longitudeDisplacement)
deallocate (airTemperature)
deallocate (dewpointTemperature)
deallocate (windDirection)
deallocate (windSpeed)
deallocate (extendedVerticalSoundingSignificance)
! Release the bufr message
call codes_release(ibufr)
! Load the next bufr message
call codes_bufr_new_from_file(ifile, ibufr, iret)
count = count + 1
end do
! Close file
call codes_close_file(ifile)
end program bufr_read_temp

281
examples/F90/bufr_read_tempf.f90
View File

@ -18,161 +18,160 @@
! example. It is advised to use bufr_dump first to understand the structure of these messages.
!
program bufr_read_temp
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i, count=0
integer :: iflag
integer :: status_id, status_ht, status_time=0, status_p
integer :: status_rsno, status_rssoft, statid_missing
integer(kind=4) :: sizews
integer(kind=4) :: blockNumber,stationNumber
integer(kind=4) :: ymd,hms
logical :: llstdonly = .True. ! Set True to list standard levels only
logical :: llskip
real(kind=8) :: year,month,day,hour,minute,second
real(kind=8) :: htg,htp,htec=0,sondeType
real(kind=8), dimension(:), allocatable :: lat,lon
real(kind=8), dimension(:), allocatable :: timeVal,dlatVal,dlonVal,vssVal
real(kind=8), dimension(:), allocatable :: presVal,zVal,tVal,tdVal,wdirVal,wspVal
character(len=128) :: statid
character(len=16) :: rsnumber
character(len=16) :: rssoftware
character(len=8) :: Note
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i, count = 0
integer :: iflag
integer :: status_id, status_ht, status_time = 0, status_p
integer :: status_rsno, status_rssoft, statid_missing
integer(kind=4) :: sizews
integer(kind=4) :: blockNumber, stationNumber
integer(kind=4) :: ymd, hms
logical :: llstdonly = .True. ! Set True to list standard levels only
logical :: llskip
real(kind=8) :: year, month, day, hour, minute, second
real(kind=8) :: htg, htp, htec = 0, sondeType
real(kind=8), dimension(:), allocatable :: lat, lon
real(kind=8), dimension(:), allocatable :: timeVal, dlatVal, dlonVal, vssVal
real(kind=8), dimension(:), allocatable :: presVal, zVal, tVal, tdVal, wdirVal, wspVal
character(len=128) :: statid
character(len=16) :: rsnumber
character(len=16) :: rssoftware
character(len=8) :: Note
call codes_open_file(ifile,'../../data/bufr/PraticaTemp.bufr','r')
call codes_open_file(ifile, '../../data/bufr/PraticaTemp.bufr', 'r')
! the first bufr message is loaded from file
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
! the first bufr message is loaded from file
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile, ibufr, iret)
! do while (iret/=CODES_END_OF_FILE)
do while (iret/=CODES_END_OF_FILE .AND. status_time==CODES_SUCCESS)
! do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE .AND. status_time == CODES_SUCCESS)
! we need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr,"unpack",1);
! we need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr, "unpack", 1);
! In our BUFR message verticalSoundingSignificance is always followed by
! geopotential, airTemperature, dewpointTemperature,
! windDirection, windSpeed and pressure.
!
! In our BUFR message verticalSoundingSignificance is always followed by
! geopotential, airTemperature, dewpointTemperature,
! windDirection, windSpeed and pressure.
!
count = count + 1
llskip = .False.
count=count+1
llskip=.False.
! Metadata:
call codes_get(ibufr, 'shipOrMobileLandStationIdentifier', statid, status_id)
IF (status_id /= CODES_SUCCESS) statid = "UNKNOWN"
call codes_is_missing(ibufr, 'shipOrMobileLandStationIdentifier', statid_missing)
IF (statid_missing == 1) statid = "MISSING"
call codes_get(ibufr, 'blockNumber', blockNumber)
call codes_get(ibufr, 'stationNumber', stationNumber)
call codes_get(ibufr, 'year', year)
call codes_get(ibufr, 'month', month)
call codes_get(ibufr, 'day', day)
call codes_get(ibufr, 'hour', hour)
call codes_get(ibufr, 'minute', minute)
call codes_get(ibufr, 'second', second, status_time)
IF (status_time /= CODES_SUCCESS) second = 0.0
call codes_get(ibufr, 'latitude', lat)
call codes_get(ibufr, 'longitude', lon)
call codes_get(ibufr, 'heightOfStationGroundAboveMeanSeaLevel', htg, status_ht)
IF (status_ht /= CODES_SUCCESS) htg = -999.0
call codes_get(ibufr, 'heightOfBarometerAboveMeanSeaLevel', htp, status_ht)
IF (status_ht /= CODES_SUCCESS) htp = -999.0
call codes_get(ibufr, 'radiosondeType', sondeType)
call codes_get(ibufr, 'heightOfStation', htec, status_ht) ! Height from WMO list (BUFR)
IF (status_ht == CODES_SUCCESS .AND. htg == -999.0) htg = htec
ymd = INT(year)*10000 + INT(month)*100 + INT(day)
hms = INT(hour)*10000 + INT(minute)*100 + INT(second)
call codes_get(ibufr, 'radiosondeSerialNumber', rsnumber, status_rsno)
call codes_get(ibufr, 'softwareVersionNumber', rssoftware, status_rssoft)
! Metadata:
call codes_get(ibufr,'shipOrMobileLandStationIdentifier',statid,status_id)
IF (status_id /= CODES_SUCCESS) statid = "UNKNOWN"
call codes_is_missing(ibufr,'shipOrMobileLandStationIdentifier',statid_missing)
IF (statid_missing == 1) statid = "MISSING"
call codes_get(ibufr,'blockNumber',blockNumber)
call codes_get(ibufr,'stationNumber',stationNumber)
call codes_get(ibufr,'year',year)
call codes_get(ibufr,'month',month)
call codes_get(ibufr,'day',day)
call codes_get(ibufr,'hour',hour)
call codes_get(ibufr,'minute',minute)
call codes_get(ibufr,'second',second,status_time)
IF (status_time /= CODES_SUCCESS) second = 0.0
call codes_get(ibufr,'latitude',lat)
call codes_get(ibufr,'longitude',lon)
call codes_get(ibufr,'heightOfStationGroundAboveMeanSeaLevel',htg,status_ht)
IF (status_ht /= CODES_SUCCESS) htg = -999.0
call codes_get(ibufr,'heightOfBarometerAboveMeanSeaLevel',htp,status_ht)
IF (status_ht /= CODES_SUCCESS) htp = -999.0
call codes_get(ibufr,'radiosondeType',sondeType)
call codes_get(ibufr,'heightOfStation',htec,status_ht) ! Height from WMO list (BUFR)
IF (status_ht == CODES_SUCCESS .AND. htg == -999.0) htg = htec
ymd = INT(year)*10000+INT(month)*100+INT(day)
hms = INT(hour)*10000+INT(minute)*100+INT(second)
call codes_get(ibufr,'radiosondeSerialNumber',rsnumber,status_rsno)
call codes_get(ibufr,'softwareVersionNumber',rssoftware,status_rssoft)
! Ascent (skip incomplete reports for now)
call codes_get(ibufr, 'timePeriod', timeVal, status_time)
IF (status_time /= CODES_SUCCESS) THEN
write (*, '(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ', count, &
' ', blockNumber, ' ', stationNumber, ymd, hms, lat(1), lon(1), htg, htp, INT(sondeType)
write (*, '(A)') 'Missing times - skip'
llskip = .True.
END IF
call codes_get(ibufr, 'pressure', presVal, status_p)
IF (status_p /= CODES_SUCCESS) THEN
write (*, '(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ', count, &
' ', blockNumber, ' ', stationNumber, ymd, hms, lat(1), lon(1), htg, htp, INT(sondeType)
write (*, '(A)') 'Missing pressures - skip'
llskip = .True.
END IF
call codes_get(ibufr, 'nonCoordinateGeopotentialHeight', zVal, status_ht)
IF (status_ht /= CODES_SUCCESS) THEN
write (*, '(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ', count, &
' ', blockNumber, ' ', stationNumber, ymd, hms, lat(1), lon(1), htg, htp, INT(sondeType)
write (*, '(A)') 'Missing heights - skip'
llskip = .True.
END IF
! IF (blockNumber /= 17 .OR. stationNumber /= 196) llskip=.True. ! FIX
! IF (blockNumber /= 17.0) llskip=.True. ! FIX
! Ascent (skip incomplete reports for now)
call codes_get(ibufr,'timePeriod',timeVal,status_time)
IF (status_time /= CODES_SUCCESS) THEN
write(*,'(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ',count, &
' ',blockNumber,' ',stationNumber,ymd,hms,lat(1),lon(1),htg,htp,INT(sondeType)
write(*,'(A)') 'Missing times - skip'
llskip=.True.
ENDIF
call codes_get(ibufr,'pressure',presVal,status_p)
IF (status_p /= CODES_SUCCESS) THEN
write(*,'(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ',count, &
' ',blockNumber,' ',stationNumber,ymd,hms,lat(1),lon(1),htg,htp,INT(sondeType)
write(*,'(A)') 'Missing pressures - skip'
llskip=.True.
ENDIF
call codes_get(ibufr,'nonCoordinateGeopotentialHeight',zVal,status_ht)
IF (status_ht /= CODES_SUCCESS) THEN
write(*,'(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ',count, &
' ',blockNumber,' ',stationNumber,ymd,hms,lat(1),lon(1),htg,htp,INT(sondeType)
write(*,'(A)') 'Missing heights - skip'
llskip=.True.
ENDIF
! IF (blockNumber /= 17 .OR. stationNumber /= 196) llskip=.True. ! FIX
! IF (blockNumber /= 17.0) llskip=.True. ! FIX
IF (.NOT. llskip) THEN
call codes_get(ibufr, 'latitudeDisplacement', dlatVal)
call codes_get(ibufr, 'longitudeDisplacement', dlonVal)
call codes_get(ibufr, 'extendedVerticalSoundingSignificance', vssVal)
!call codes_get(ibufr,'geopotentialHeight',zVal)
call codes_get(ibufr, 'airTemperature', tVal)
call codes_get(ibufr, 'dewpointTemperature', tdVal)
call codes_get(ibufr, 'windDirection', wdirVal)
call codes_get(ibufr, 'windSpeed', wspVal)
IF (.NOT.llskip) THEN
call codes_get(ibufr,'latitudeDisplacement',dlatVal)
call codes_get(ibufr,'longitudeDisplacement',dlonVal)
call codes_get(ibufr,'extendedVerticalSoundingSignificance',vssVal)
!call codes_get(ibufr,'geopotentialHeight',zVal)
call codes_get(ibufr,'airTemperature',tVal)
call codes_get(ibufr,'dewpointTemperature',tdVal)
call codes_get(ibufr,'windDirection',wdirVal)
call codes_get(ibufr,'windSpeed',wspVal)
! ---- Array sizes (pressure size can be larger - wind shear levels)
sizews = size(wspVal)
! ---- Array sizes (pressure size can be larger - wind shear levels)
sizews = size(wspVal)
! ---- Print the values --------------------------------
write (*, '(A,A72)') 'Statid: ', statid
write (*, '(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4,I5)') 'Ob: ', count, &
' ', blockNumber, ' ', stationNumber, ymd, hms, lat(1), lon(1), htg, htp, INT(sondeType), sizews
IF (status_ht == CODES_SUCCESS) write (*, '(A,F9.3,F10.3,F7.1)') &
'WMO list lat, lon, ht: ', lat(1), lon(1), htec
IF (status_rsno == CODES_SUCCESS) write (*, '(A,A,A)') &
'Radiosonde number/software: ', rsnumber, rssoftware
write (*, '(A)') 'level dtime dlat dlon pressure geopotH airTemp dewPtT windDir windSp signif'
do i = 1, sizews
Note = ' '
iflag = vssVal(i)
IF (i > 1) THEN
IF (presVal(i) > presVal(i - 1) .OR. zVal(i) < zVal(i - 1) &
.OR. timeVal(i) < timeVal(i - 1)) Note = ' OOO '
IF ((timeVal(i) - timeVal(i - 1)) > 120) Note = ' tjump '
IF (ABS(dlatVal(i) - dlatVal(i - 1)) > 0.1 .OR. &
ABS(dlonVal(i) - dlonVal(i - 1)) > 0.1) THEN
Note = ' pjump '
IF (dlatVal(i) == CODES_MISSING_DOUBLE .OR. &
dlatVal(i - 1) == CODES_MISSING_DOUBLE) Note = ' pmiss '
END IF
END IF
IF (.NOT. llstdonly .OR. BTEST(iflag, 16)) &
write (*, '(I5,F7.1,2F7.3,F9.1,F8.1,4F8.2,I8,A)') i, timeVal(i), &
dlatVal(i), dlonVal(i), presVal(i), zVal(i), tVal(i), tVal(i) - tdVal(i), &
wdirVal(i), wspVal(i), INT(vssVal(i)), Note
end do
! ---- Print the values --------------------------------
write(*,'(A,A72)') 'Statid: ',statid
write(*,'(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4,I5)') 'Ob: ',count, &
' ',blockNumber,' ',stationNumber,ymd,hms,lat(1),lon(1),htg,htp,INT(sondeType),sizews
IF (status_ht == CODES_SUCCESS) write(*,'(A,F9.3,F10.3,F7.1)') &
'WMO list lat, lon, ht: ', lat(1),lon(1),htec
IF (status_rsno == CODES_SUCCESS) write(*,'(A,A,A)') &
'Radiosonde number/software: ', rsnumber, rssoftware
write(*,'(A)') 'level dtime dlat dlon pressure geopotH airTemp dewPtT windDir windSp signif'
do i=1,sizews
Note = ' '
iflag = vssVal(i)
IF (i > 1) THEN
IF (presVal(i) > presVal(i-1) .OR. zVal(i) < zVal(i-1) &
.OR. timeVal(i) < timeVal(i-1)) Note=' OOO '
IF ((timeVal(i)-timeVal(i-1))>120) Note=' tjump '
IF (ABS(dlatVal(i)-dlatVal(i-1))>0.1 .OR. &
ABS(dlonVal(i)-dlonVal(i-1))>0.1) THEN
Note=' pjump '
IF (dlatVal(i) == CODES_MISSING_DOUBLE .OR. &
dlatVal(i-1) == CODES_MISSING_DOUBLE) Note=' pmiss '
ENDIF
ENDIF
IF (.NOT.llstdonly .OR. BTEST(iflag,16)) &
write(*,'(I5,F7.1,2F7.3,F9.1,F8.1,4F8.2,I8,A)') i,timeVal(i), &
dlatVal(i),dlonVal(i),presVal(i),zVal(i),tVal(i),tVal(i)-tdVal(i), &
wdirVal(i),wspVal(i),INT(vssVal(i)), Note
end do
! free arrays
deallocate (dlatVal, dlonVal, vssVal)
deallocate (presVal, zVal, tVal, tdVal, wdirVal, wspVal)
END IF
IF (ALLOCATED(timeVal)) deallocate (timeVal)
! free arrays
deallocate(dlatVal,dlonVal,vssVal)
deallocate(presVal,zVal,tVal,tdVal,wdirVal,wspVal)
END IF
IF (ALLOCATED(timeVal)) deallocate(timeVal)
! release the bufr message
call codes_release(ibufr)
! release the bufr message
call codes_release(ibufr)
! load the next bufr message
call codes_bufr_new_from_file(ifile, ibufr, iret)
! load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
end do
end do
! close file
call codes_close_file(ifile)
! close file
call codes_close_file(ifile)
end program bufr_read_temp

362
examples/F90/bufr_read_tropical_cyclone.f90
View File

@ -21,254 +21,254 @@ program bufr_read_tropical_cyclone
implicit none
integer :: ifile
integer :: iret
integer :: ibufr,skipMember
integer :: ibufr, skipMember
integer :: significance
integer :: year,month,day,hour,minute
integer :: i,j,k,ierr,count=1
integer :: rankPosition,rankSignificance,rankPressure,rankWind
integer :: rankPeriod,numberOfPeriods
integer :: year, month, day, hour, minute
integer :: i, j, k, ierr, count = 1
integer :: rankPosition, rankSignificance, rankPressure, rankWind
integer :: rankPeriod, numberOfPeriods
real(kind=8) :: latitudeCentre,longitudeCentre
real(kind=8), dimension(:), allocatable :: latitudeMaxWind0,longitudeMaxWind0,windMaxWind0
real(kind=8), dimension(:), allocatable :: latitudeAnalysis,longitudeAnalysis,pressureAnalysis
real(kind=8), dimension(:,:), allocatable :: latitude,longitude,pressure
real(kind=8), dimension(:,:), allocatable :: latitudeWind,longitudeWind,wind
integer(kind=4), dimension(:), allocatable :: memberNumber,period
real(kind=8) :: latitudeCentre, longitudeCentre
real(kind=8), dimension(:), allocatable :: latitudeMaxWind0, longitudeMaxWind0, windMaxWind0
real(kind=8), dimension(:), allocatable :: latitudeAnalysis, longitudeAnalysis, pressureAnalysis
real(kind=8), dimension(:, :), allocatable :: latitude, longitude, pressure
real(kind=8), dimension(:, :), allocatable :: latitudeWind, longitudeWind, wind
integer(kind=4), dimension(:), allocatable :: memberNumber, period
real(kind=8), dimension(:), allocatable :: values
integer(kind=4), dimension(:), allocatable :: ivalues
character(len=8) :: rankSignificanceStr,rankPositionStr,rankPressureStr,rankWindStr
character(len=8) :: stormIdentifier,rankPeriodStr
character(len=8) :: rankSignificanceStr, rankPositionStr, rankPressureStr, rankWindStr
character(len=8) :: stormIdentifier, rankPeriodStr
call codes_open_file(ifile,'../../data/bufr/tropical_cyclone.bufr','r')
call codes_open_file(ifile, '../../data/bufr/tropical_cyclone.bufr', 'r')
! The first BUFR message is loaded from file.
! ibufr is the BUFR id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
call codes_bufr_new_from_file(ifile, ibufr, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
write(*,'(A,I3,A)') '**************** MESSAGE: ',count,' *****************'
write (*, '(A,I3,A)') '**************** MESSAGE: ', count, ' *****************'
! We need to instruct ecCodes to unpack the data values
call codes_set(ibufr,"unpack",1);
call codes_set(ibufr, "unpack", 1);
call codes_get(ibufr, 'year', year);
call codes_get(ibufr, 'month', month);
call codes_get(ibufr, 'day', day);
call codes_get(ibufr, 'hour', hour);
call codes_get(ibufr, 'minute', minute);
write (*, '(A,I0,A,I0,A,I0,A,I0,A,I0,A,I0)') 'Date and time: ', day, '.', month, '.', year, ' ', hour, ':', minute
call codes_get(ibufr,'year',year);
call codes_get(ibufr,'month',month);
call codes_get(ibufr,'day',day);
call codes_get(ibufr,'hour',hour);
call codes_get(ibufr,'minute',minute);
write(*,'(A,I0,A,I0,A,I0,A,I0,A,I0,A,I0)')'Date and time: ',day,'.',month,'.',year,' ',hour,':',minute
call codes_get(ibufr,'stormIdentifier',stormIdentifier)
write(*,'(A,A)')'Storm identifier: ',stormIdentifier
call codes_get(ibufr, 'stormIdentifier', stormIdentifier)
write (*, '(A,A)') 'Storm identifier: ', stormIdentifier
! How many different timePeriod in the data structure?
rankPeriod=0
ierr=0
do while(ierr==0)
rankPeriod=rankPeriod+1
write (rankPeriodStr,'(I0)')rankPeriod
call codes_get(ibufr,'#'//trim(rankPeriodStr)//'#timePeriod',period,ierr)
if(allocated(period)) deallocate(period)
enddo
rankPeriod = 0
ierr = 0
do while (ierr == 0)
rankPeriod = rankPeriod + 1
write (rankPeriodStr, '(I0)') rankPeriod
call codes_get(ibufr, '#'//trim(rankPeriodStr)//'#timePeriod', period, ierr)
if (allocated(period)) deallocate (period)
end do
! The numberOfPeriods includes the analysis (period=0)
numberOfPeriods=rankPeriod
numberOfPeriods = rankPeriod
call codes_get(ibufr,'ensembleMemberNumber',memberNumber)
call codes_get(ibufr, 'ensembleMemberNumber', memberNumber)
allocate(latitude(size(memberNumber),numberOfPeriods))
allocate(longitude(size(memberNumber),numberOfPeriods))
allocate(pressure(size(memberNumber),numberOfPeriods))
allocate(latitudeWind(size(memberNumber),numberOfPeriods))
allocate(longitudeWind(size(memberNumber),numberOfPeriods))
allocate(wind(size(memberNumber),numberOfPeriods))
allocate(values(size(memberNumber)))
allocate(period(numberOfPeriods))
period(1)=0
allocate (latitude(size(memberNumber), numberOfPeriods))
allocate (longitude(size(memberNumber), numberOfPeriods))
allocate (pressure(size(memberNumber), numberOfPeriods))
allocate (latitudeWind(size(memberNumber), numberOfPeriods))
allocate (longitudeWind(size(memberNumber), numberOfPeriods))
allocate (wind(size(memberNumber), numberOfPeriods))
allocate (values(size(memberNumber)))
allocate (period(numberOfPeriods))
period(1) = 0
! Observed Storm Centre
call codes_get(ibufr,'#1#meteorologicalAttributeSignificance',significance);
call codes_get(ibufr,'#1#latitude',latitudeCentre);
call codes_get(ibufr,'#1#longitude',longitudeCentre);
if (significance/=1) then
print *,'ERROR: unexpected #1#meteorologicalAttributeSignificance'
call codes_get(ibufr, '#1#meteorologicalAttributeSignificance', significance);
call codes_get(ibufr, '#1#latitude', latitudeCentre);
call codes_get(ibufr, '#1#longitude', longitudeCentre);
if (significance /= 1) then
print *, 'ERROR: unexpected #1#meteorologicalAttributeSignificance'
stop 1
endif
if (latitudeCentre==CODES_MISSING_DOUBLE .and. longitudeCentre==CODES_MISSING_DOUBLE) then
write(*,'(a)')'Observed storm centre position missing'
end if
if (latitudeCentre == CODES_MISSING_DOUBLE .and. longitudeCentre == CODES_MISSING_DOUBLE) then
write (*, '(a)') 'Observed storm centre position missing'
else
write(*,'(A,F8.2,A,F8.2)')'Observed storm centre: latitude=',latitudeCentre,' longitude=',longitudeCentre
endif
write (*, '(A,F8.2,A,F8.2)') 'Observed storm centre: latitude=', latitudeCentre, ' longitude=', longitudeCentre
end if
! Location of storm in perturbed analysis
call codes_get(ibufr,'#2#meteorologicalAttributeSignificance',significance);
call codes_get(ibufr,'#2#latitude',latitudeAnalysis);
call codes_get(ibufr,'#2#longitude',longitudeAnalysis);
call codes_get(ibufr,'#1#pressureReducedToMeanSeaLevel',pressureAnalysis);
if (significance/=4) then
print *,'ERROR: unexpected #2#meteorologicalAttributeSignificance'
call codes_get(ibufr, '#2#meteorologicalAttributeSignificance', significance);
call codes_get(ibufr, '#2#latitude', latitudeAnalysis);
call codes_get(ibufr, '#2#longitude', longitudeAnalysis);
call codes_get(ibufr, '#1#pressureReducedToMeanSeaLevel', pressureAnalysis);
if (significance /= 4) then
print *, 'ERROR: unexpected #2#meteorologicalAttributeSignificance'
stop 1
endif
if (size(latitudeAnalysis)==size(memberNumber)) then
latitude(:,1)=latitudeAnalysis
longitude(:,1)=longitudeAnalysis
pressure(:,1)=pressureAnalysis
end if
if (size(latitudeAnalysis) == size(memberNumber)) then
latitude(:, 1) = latitudeAnalysis
longitude(:, 1) = longitudeAnalysis
pressure(:, 1) = pressureAnalysis
else
latitude(:,1)=latitudeAnalysis(1)
longitude(:,1)=longitudeAnalysis(1)
pressure(:,1)=pressureAnalysis(1)
endif
latitude(:, 1) = latitudeAnalysis(1)
longitude(:, 1) = longitudeAnalysis(1)
pressure(:, 1) = pressureAnalysis(1)
end if
! Location of Maximum Wind
call codes_get(ibufr,'#3#meteorologicalAttributeSignificance',significance);
call codes_get(ibufr,'#3#latitude',latitudeMaxWind0);
call codes_get(ibufr,'#3#longitude',longitudeMaxWind0);
if (significance/=3) then
print *,'ERROR: unexpected #3#meteorologicalAttributeSignificance=',significance
call codes_get(ibufr, '#3#meteorologicalAttributeSignificance', significance);
call codes_get(ibufr, '#3#latitude', latitudeMaxWind0);
call codes_get(ibufr, '#3#longitude', longitudeMaxWind0);
if (significance /= 3) then
print *, 'ERROR: unexpected #3#meteorologicalAttributeSignificance=', significance
stop 1
endif
call codes_get(ibufr,'#1#windSpeedAt10M',windMaxWind0);
if (size(latitudeMaxWind0)==size(memberNumber)) then
latitudeWind(:,1)=latitudeMaxWind0
longitudeWind(:,1)=longitudeMaxWind0
wind(:,1)=windMaxWind0
end if
call codes_get(ibufr, '#1#windSpeedAt10M', windMaxWind0);
if (size(latitudeMaxWind0) == size(memberNumber)) then
latitudeWind(:, 1) = latitudeMaxWind0
longitudeWind(:, 1) = longitudeMaxWind0
wind(:, 1) = windMaxWind0
else
latitudeWind(:,1)=latitudeMaxWind0(1)
longitudeWind(:,1)=longitudeMaxWind0(1)
wind(:,1)=windMaxWind0(1)
endif
latitudeWind(:, 1) = latitudeMaxWind0(1)
longitudeWind(:, 1) = longitudeMaxWind0(1)
wind(:, 1) = windMaxWind0(1)
end if
rankSignificance=3
rankPosition=3
rankPressure=1
rankWind=1
rankPeriod=0
rankSignificance = 3
rankPosition = 3
rankPressure = 1
rankWind = 1
rankPeriod = 0
! Loop on all periods excluding analysis period(1)=0
do i=2,numberOfPeriods
do i = 2, numberOfPeriods
rankPeriod=rankPeriod+1
write (rankPeriodStr,'(I0)')rankPeriod
call codes_get(ibufr,'#'//trim(rankPeriodStr)//'#timePeriod',ivalues);
do k=1,size(ivalues)
if (ivalues(k)/=CODES_MISSING_LONG) then
period(i)=ivalues(k)
rankPeriod = rankPeriod + 1
write (rankPeriodStr, '(I0)') rankPeriod
call codes_get(ibufr, '#'//trim(rankPeriodStr)//'#timePeriod', ivalues);
do k = 1, size(ivalues)
if (ivalues(k) /= CODES_MISSING_LONG) then
period(i) = ivalues(k)
exit
endif
enddo
deallocate(ivalues)
end if
end do
deallocate (ivalues)
! Location of the storm
rankSignificance=rankSignificance+1
write (rankSignificanceStr,'(I0)')rankSignificance
call codes_get(ibufr,'#'//trim(rankSignificanceStr)//'#meteorologicalAttributeSignificance',ivalues);
do k=1,size(ivalues)
if (ivalues(k)/=CODES_MISSING_LONG) then
significance=ivalues(k)
rankSignificance = rankSignificance + 1
write (rankSignificanceStr, '(I0)') rankSignificance
call codes_get(ibufr, '#'//trim(rankSignificanceStr)//'#meteorologicalAttributeSignificance', ivalues);
do k = 1, size(ivalues)
if (ivalues(k) /= CODES_MISSING_LONG) then
significance = ivalues(k)
exit
endif
enddo
deallocate(ivalues)
end if
end do
deallocate (ivalues)
rankPosition=rankPosition+1
write (rankPositionStr,'(I0)')rankPosition
call codes_get(ibufr,'#'//trim(rankPositionStr)//'#latitude',values);
latitude(:,i)=values
call codes_get(ibufr,'#'//trim(rankPositionStr)//'#longitude',values);
longitude(:,i)=values
rankPosition = rankPosition + 1
write (rankPositionStr, '(I0)') rankPosition
call codes_get(ibufr, '#'//trim(rankPositionStr)//'#latitude', values);
latitude(:, i) = values
call codes_get(ibufr, '#'//trim(rankPositionStr)//'#longitude', values);
longitude(:, i) = values
if (significance==1) then
rankPressure=rankPressure+1
write (rankPressureStr,'(I0)')rankPressure
call codes_get(ibufr,'#'//trim(rankPressureStr)//'#pressureReducedToMeanSeaLevel',values);
pressure(:,i)=values
if (significance == 1) then
rankPressure = rankPressure + 1
write (rankPressureStr, '(I0)') rankPressure
call codes_get(ibufr, '#'//trim(rankPressureStr)//'#pressureReducedToMeanSeaLevel', values);
pressure(:, i) = values
else
print *,'ERROR: unexpected meteorologicalAttributeSignificance=',significance
print *, 'ERROR: unexpected meteorologicalAttributeSignificance=', significance
stop 1
endif
end if
! Location of maximum wind
rankSignificance=rankSignificance+1
write (rankSignificanceStr,'(I0)')rankSignificance
call codes_get(ibufr,'#'//trim(rankSignificanceStr)//'#meteorologicalAttributeSignificance',ivalues);
do k=1,size(ivalues)
if (ivalues(k)/=CODES_MISSING_LONG) then
significance=ivalues(k)
rankSignificance = rankSignificance + 1
write (rankSignificanceStr, '(I0)') rankSignificance
call codes_get(ibufr, '#'//trim(rankSignificanceStr)//'#meteorologicalAttributeSignificance', ivalues);
do k = 1, size(ivalues)
if (ivalues(k) /= CODES_MISSING_LONG) then
significance = ivalues(k)
exit
endif
enddo
deallocate(ivalues)
end if
end do
deallocate (ivalues)
rankPosition=rankPosition+1
write (rankPositionStr,'(I0)')rankPosition
call codes_get(ibufr,'#'//trim(rankPositionStr)//'#latitude',values);
latitudeWind(:,i)=values
call codes_get(ibufr,'#'//trim(rankPositionStr)//'#longitude',values);
longitudeWind(:,i)=values
rankPosition = rankPosition + 1
write (rankPositionStr, '(I0)') rankPosition
call codes_get(ibufr, '#'//trim(rankPositionStr)//'#latitude', values);
latitudeWind(:, i) = values
call codes_get(ibufr, '#'//trim(rankPositionStr)//'#longitude', values);
longitudeWind(:, i) = values
if (significance==3) then
rankWind=rankWind+1
write (rankWindStr,'(I0)')rankWind
call codes_get(ibufr,'#'//trim(rankWindStr)//'#windSpeedAt10M',values);
wind(:,i)=values
if (significance == 3) then
rankWind = rankWind + 1
write (rankWindStr, '(I0)') rankWind
call codes_get(ibufr, '#'//trim(rankWindStr)//'#windSpeedAt10M', values);
wind(:, i) = values
else
print *,'ERROR: unexpected meteorologicalAttributeSignificance=,',significance
print *, 'ERROR: unexpected meteorologicalAttributeSignificance=,', significance
stop 1
endif
end if
enddo
end do
! Print the values
do i=1,size(memberNumber)
skipMember=1
do j=1,size(period)
if (latitude(i,j)/=CODES_MISSING_DOUBLE .OR. latitudeWind(i,j)/=CODES_MISSING_DOUBLE) then
skipMember=0
do i = 1, size(memberNumber)
skipMember = 1
do j = 1, size(period)
if (latitude(i, j) /= CODES_MISSING_DOUBLE .OR. latitudeWind(i, j) /= CODES_MISSING_DOUBLE) then
skipMember = 0
exit
endif
enddo
if (skipMember/=1) then
end if
end do
if (skipMember /= 1) then
write(*,'(A,I3)') '== Member ',memberNumber(i)
write(*,*) 'step latitude longitude pressure latitude longitude wind'
do j=1,size(period)
if (latitude(i,j)/=CODES_MISSING_DOUBLE .OR. latitudeWind(i,j)/=CODES_MISSING_DOUBLE) then
write(*,'( I4,2X,F8.2,4X,F8.2,3X,F9.1,2X,F8.2,4X,F8.2,2X,F8.2)') period(j),latitude(i,j),longitude(i,j),pressure(i,j),&
&latitudeWind(i,j),longitudeWind(i,j),wind(i,j)
endif
enddo
write (*, '(A,I3)') '== Member ', memberNumber(i)
write (*, *) 'step latitude longitude pressure latitude longitude wind'
do j = 1, size(period)
if (latitude(i, j) /= CODES_MISSING_DOUBLE .OR. latitudeWind(i, j) /= CODES_MISSING_DOUBLE) then
write (*, '( I4,2X,F8.2,4X,F8.2,3X,F9.1,2X,F8.2,4X,F8.2,2X,F8.2)') &
period(j), latitude(i, j), longitude(i, j), pressure(i, j), &
latitudeWind(i, j), longitudeWind(i, j), wind(i, j)
end if
end do
endif
enddo
end if
end do
! deallocating the arrays is very important
! because the behaviour of the codes_get functions is as follows:
! if the array is not allocated then allocate
! if the array is already allocated only copy the values
deallocate(values)
deallocate(latitude)
deallocate(longitude)
deallocate(pressure)
deallocate(latitudeWind)
deallocate(longitudeWind)
deallocate(wind)
deallocate(period)
deallocate(latitudeAnalysis)
deallocate(longitudeAnalysis)
deallocate(pressureAnalysis)
deallocate(memberNumber)
deallocate(latitudeMaxWind0)
deallocate(longitudeMaxWind0)
deallocate(windMaxWind0)
deallocate (values)
deallocate (latitude)
deallocate (longitude)
deallocate (pressure)
deallocate (latitudeWind)
deallocate (longitudeWind)
deallocate (wind)
deallocate (period)
deallocate (latitudeAnalysis)
deallocate (longitudeAnalysis)
deallocate (pressureAnalysis)
deallocate (memberNumber)
deallocate (latitudeMaxWind0)
deallocate (longitudeMaxWind0)
deallocate (windMaxWind0)
! Release the BUFR message
call codes_release(ibufr)
! Load the next BUFR message
call codes_bufr_new_from_file(ifile,ibufr,iret)
call codes_bufr_new_from_file(ifile, ibufr, iret)
count=count+1
count = count + 1
end do

72
examples/F90/bufr_set_keys.f90
View File

@ -12,55 +12,55 @@
!
!
program bufr_set_keys
use eccodes
implicit none
integer :: iret
integer :: infile,outfile
integer :: ibufr
integer :: count=0
integer(kind=4) :: centre, centreNew
use eccodes
implicit none
integer :: iret
integer :: infile, outfile
integer :: ibufr
integer :: count = 0
integer(kind=4) :: centre, centreNew
! Open input file
call codes_open_file(infile,'../../data/bufr/syno_multi.bufr','r')
! Open input file
call codes_open_file(infile, '../../data/bufr/syno_multi.bufr', 'r')
! Open output file
call codes_open_file(outfile,'bufr_set_keys_test_f.tmp.bufr','w')
! Open output file
call codes_open_file(outfile, 'bufr_set_keys_test_f.tmp.bufr', 'w')
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(infile,ibufr,iret)
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(infile, ibufr, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
write(*,*) 'message: ',count
write (*, *) 'message: ', count
! This is the place where you may wish to modify the message
! E.g. we change the centre
! This is the place where you may wish to modify the message
! E.g. we change the centre
! Set centre
centre=222
call codes_set(ibufr,'bufrHeaderCentre',222)
write(*,*) ' set bufrHeaderCentre to:',centre
! Set centre
centre = 222
call codes_set(ibufr, 'bufrHeaderCentre', 222)
write (*, *) ' set bufrHeaderCentre to:', centre
! Check centre's new value
centreNew=0
call codes_get(ibufr,'bufrHeaderCentre',centreNew)
write(*,*) ' bufrHeaderCentre''s new value:',centreNew
! Check centre's new value
centreNew = 0
call codes_get(ibufr, 'bufrHeaderCentre', centreNew)
write (*, *) ' bufrHeaderCentre''s new value:', centreNew
! Write modified message to a file
call codes_write(ibufr,outfile)
! Write modified message to a file
call codes_write(ibufr, outfile)
! Release the handle
call codes_release(ibufr)
! Release the handle
call codes_release(ibufr)
! Next message from source
call codes_bufr_new_from_file(infile,ibufr,iret)
! Next message from source
call codes_bufr_new_from_file(infile, ibufr, iret)
count=count+1
count = count + 1
end do
end do
call codes_close_file(infile)
call codes_close_file(outfile)
call codes_close_file(infile)
call codes_close_file(outfile)
end program bufr_set_keys

87
examples/F90/bufr_subset.f90
View File

@ -13,66 +13,65 @@
!
!
program bufr_subset
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i, count=0
integer(kind=4) :: numberOfSubsets
integer(kind=4) :: blockNumber,stationNumber
character(100) :: key
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i, count = 0
integer(kind=4) :: numberOfSubsets
integer(kind=4) :: blockNumber, stationNumber
character(100) :: key
!real(kind=8) :: t2m
call codes_open_file(ifile,'../../data/bufr/synop_multi_subset.bufr','r')
call codes_open_file(ifile, '../../data/bufr/synop_multi_subset.bufr', 'r')
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile, ibufr, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
! Get and print some keys form the BUFR header
write(*,*) 'message: ',count
! Get and print some keys form the BUFR header
write (*, *) 'message: ', count
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr,'unpack',1);
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr, 'unpack', 1);
! Find out the number of subsets
call codes_get(ibufr, 'numberOfSubsets', numberOfSubsets)
write (*, *) ' numberOfSubsets:', numberOfSubsets
! Find out the number of subsets
call codes_get(ibufr,'numberOfSubsets',numberOfSubsets)
write(*,*) ' numberOfSubsets:',numberOfSubsets
! Loop over the subsets
do i = 1, numberOfSubsets
! Loop over the subsets
do i=1,numberOfSubsets
100 format('/subsetNumber=', I5.5, '/blockNumber')
write (key, 100) I
write (*, *) key
100 format('/subsetNumber=',I5.5,'/blockNumber')
write(key,100) I
write(*,*) key
write (*, *) ' subsetNumber:', i
! read and print some data values
write(*,*) ' subsetNumber:',i
! read and print some data values
call codes_get(ibufr, key, blockNumber);
write (*, *) ' blockNumber:', blockNumber
call codes_get(ibufr,key,blockNumber);
write(*,*) ' blockNumber:',blockNumber
write (key, *) '/subsetNumber=', I, '/stationNumber'
call codes_get(ibufr, 'stationNumber', stationNumber);
write (*, *) ' stationNumber:', stationNumber
write(key,*) '/subsetNumber=',I,'/stationNumber'
call codes_get(ibufr,'stationNumber',stationNumber);
write(*,*) ' stationNumber:',stationNumber
end do
end do
! Release the bufr message
call codes_release(ibufr)
! Release the bufr message
call codes_release(ibufr)
! Load the next bufr message
call codes_bufr_new_from_file(ifile, ibufr, iret)
! Load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
count = count + 1
count=count+1
end do
end do
! Close file
call codes_close_file(ifile)
! Close file
call codes_close_file(ifile)
end program bufr_subset

166
examples/F90/get_fortran.f90
View File

@ -10,108 +10,108 @@
!
!
program get
use eccodes
implicit none
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: igrib
integer :: i
real(kind=8) :: latitudeOfFirstPointInDegrees
real(kind=8) :: longitudeOfFirstPointInDegrees
real(kind=8) :: latitudeOfLastPointInDegrees
real(kind=8) :: longitudeOfLastPointInDegrees
real(kind=8) :: jDirectionIncrementInDegrees
real(kind=8) :: iDirectionIncrementInDegrees
integer(kind = 4) :: numberOfPointsAlongAParallel
integer(kind = 4) :: numberOfPointsAlongAMeridian
real(kind=8), dimension(:), allocatable :: values
integer(kind = 4) :: numberOfValues
real(kind=8) :: average
integer :: ifile
integer :: iret
integer :: igrib
integer :: i
real(kind=8) :: latitudeOfFirstPointInDegrees
real(kind=8) :: longitudeOfFirstPointInDegrees
real(kind=8) :: latitudeOfLastPointInDegrees
real(kind=8) :: longitudeOfLastPointInDegrees
real(kind=8) :: jDirectionIncrementInDegrees
real(kind=8) :: iDirectionIncrementInDegrees
integer(kind=4) :: numberOfPointsAlongAParallel
integer(kind=4) :: numberOfPointsAlongAMeridian
real(kind=8), dimension(:), allocatable :: values
integer(kind=4) :: numberOfValues
real(kind=8) :: average
call codes_open_file(ifile, &
'../../data/reduced_latlon_surface.grib1','r')
call codes_open_file(ifile, &
'../../data/reduced_latlon_surface.grib1', 'r')
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(ifile,igrib)
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(ifile, igrib)
! get as a integer
call codes_get(igrib,'numberOfPointsAlongAParallel', &
numberOfPointsAlongAParallel)
write(*,*) 'numberOfPointsAlongAParallel=', &
numberOfPointsAlongAParallel
! get as a integer
call codes_get(igrib, 'numberOfPointsAlongAParallel', &
numberOfPointsAlongAParallel)
write (*, *) 'numberOfPointsAlongAParallel=', &
numberOfPointsAlongAParallel
! get as a integer
call codes_get(igrib,'numberOfPointsAlongAMeridian', &
numberOfPointsAlongAMeridian)
write(*,*) 'numberOfPointsAlongAMeridian=', &
numberOfPointsAlongAMeridian
! get as a integer
call codes_get(igrib, 'numberOfPointsAlongAMeridian', &
numberOfPointsAlongAMeridian)
write (*, *) 'numberOfPointsAlongAMeridian=', &
numberOfPointsAlongAMeridian
! get as a real8
call codes_get(igrib, &
'latitudeOfFirstGridPointInDegrees', &
latitudeOfFirstPointInDegrees)
write(*,*) 'latitudeOfFirstGridPointInDegrees=', &
latitudeOfFirstPointInDegrees
! get as a real8
call codes_get(igrib, &
'latitudeOfFirstGridPointInDegrees', &
latitudeOfFirstPointInDegrees)
write (*, *) 'latitudeOfFirstGridPointInDegrees=', &
latitudeOfFirstPointInDegrees
! get as a real8
call codes_get(igrib, &
'longitudeOfFirstGridPointInDegrees', &
longitudeOfFirstPointInDegrees)
write(*,*) 'longitudeOfFirstGridPointInDegrees=', &
! get as a real8
call codes_get(igrib, &
'longitudeOfFirstGridPointInDegrees', &
longitudeOfFirstPointInDegrees)
write (*, *) 'longitudeOfFirstGridPointInDegrees=', &
longitudeOfFirstPointInDegrees
! get as a real8
call codes_get(igrib, &
'latitudeOfLastGridPointInDegrees', &
latitudeOfLastPointInDegrees)
write(*,*) 'latitudeOfLastGridPointInDegrees=', &
! get as a real8
call codes_get(igrib, &
'latitudeOfLastGridPointInDegrees', &
latitudeOfLastPointInDegrees)
write (*, *) 'latitudeOfLastGridPointInDegrees=', &
latitudeOfLastPointInDegrees
! get as a real8
call codes_get(igrib, &
'longitudeOfLastGridPointInDegrees', &
longitudeOfLastPointInDegrees)
write(*,*) 'longitudeOfLastGridPointInDegrees=', &
longitudeOfLastPointInDegrees
! get as a real8
call codes_get(igrib, &
'longitudeOfLastGridPointInDegrees', &
longitudeOfLastPointInDegrees)
write (*, *) 'longitudeOfLastGridPointInDegrees=', &
longitudeOfLastPointInDegrees
! get as a real8
call codes_get(igrib, &
'jDirectionIncrementInDegrees', &
jDirectionIncrementInDegrees)
write(*,*) 'jDirectionIncrementInDegrees=', &
jDirectionIncrementInDegrees
! get as a real8
call codes_get(igrib, &
'jDirectionIncrementInDegrees', &
jDirectionIncrementInDegrees)
write (*, *) 'jDirectionIncrementInDegrees=', &
jDirectionIncrementInDegrees
! get as a real8
call codes_get(igrib, &
'iDirectionIncrementInDegrees', &
iDirectionIncrementInDegrees)
write(*,*) 'iDirectionIncrementInDegrees=', &
iDirectionIncrementInDegrees
! get as a real8
call codes_get(igrib, &
'iDirectionIncrementInDegrees', &
iDirectionIncrementInDegrees)
write (*, *) 'iDirectionIncrementInDegrees=', &
iDirectionIncrementInDegrees
! get the size of the values array
call codes_get_size(igrib,'values',numberOfValues)
write(*,*) 'numberOfValues=',numberOfValues
! get the size of the values array
call codes_get_size(igrib, 'values', numberOfValues)
write (*, *) 'numberOfValues=', numberOfValues
allocate(values(2*numberOfValues), stat=iret)
! get data values
print*, size(values)
call codes_get(igrib,'values',values)
allocate (values(2*numberOfValues), stat=iret)
! get data values
print *, size(values)
call codes_get(igrib, 'values', values)
average = 0
do i=1,numberOfValues
average = average + values(i);
enddo
average = 0
do i = 1, numberOfValues
average = average + values(i);
end do
average =average / numberOfValues
average = average/numberOfValues
write(*,*)'There are ',numberOfValues, &
' average is ',average
write (*, *) 'There are ', numberOfValues, &
' average is ', average
call codes_release(igrib)
call codes_release(igrib)
call codes_close_file(ifile)
call codes_close_file(ifile)
deallocate(values)
deallocate (values)
end program get

70
examples/F90/get_product_kind.f90
View File

@ -13,54 +13,54 @@
! and print the kind of product (e.g. GRIB, BUFR etc)
!
program get_product_kind
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ihandle
integer :: count=0
integer :: version=0
character(len=32) :: product_kind
character(len=120) :: infile_name
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ihandle
integer :: count = 0
integer :: version = 0
character(len=32) :: product_kind
character(len=120) :: infile_name
call getarg(1, infile_name)
write(*,*) 'infile_name|',infile_name,'|'
call codes_open_file(ifile,infile_name,'r')
call getarg(1, infile_name)
write (*, *) 'infile_name|', infile_name, '|'
call codes_open_file(ifile, infile_name, 'r')
call codes_get_api_version(version)
write(*,*) 'API version: ',version
call codes_get_api_version(version)
write (*, *) 'API version: ', version
write(*,*) 'ecCodes settings: '
write(*,*) ' ECCODES_POSIX_THREADS: ',ECCODES_SETTINGS_POSIX_THREADS
write(*,*) ' ECCODES_OMP_THREADS: ',ECCODES_SETTINGS_OMP_THREADS
write(*,*) ' ECCODES_SETTINGS_MEMFS: ',ECCODES_SETTINGS_MEMFS
write(*,*) ' ECCODES_SETTINGS_JPEG: ',ECCODES_SETTINGS_JPEG
write(*,*) ' ECCODES_SETTINGS_PNG: ',ECCODES_SETTINGS_PNG
write(*,*) ' ECCODES_SETTINGS_AEC: ',ECCODES_SETTINGS_AEC
write (*, *) 'ecCodes settings: '
write (*, *) ' ECCODES_POSIX_THREADS: ', ECCODES_SETTINGS_POSIX_THREADS
write (*, *) ' ECCODES_OMP_THREADS: ', ECCODES_SETTINGS_OMP_THREADS
write (*, *) ' ECCODES_SETTINGS_MEMFS: ', ECCODES_SETTINGS_MEMFS
write (*, *) ' ECCODES_SETTINGS_JPEG: ', ECCODES_SETTINGS_JPEG
write (*, *) ' ECCODES_SETTINGS_PNG: ', ECCODES_SETTINGS_PNG
write (*, *) ' ECCODES_SETTINGS_AEC: ', ECCODES_SETTINGS_AEC
! the first message is loaded from file
! ihandle is the message id to be used in subsequent calls
call codes_new_from_file(ifile,ihandle,CODES_PRODUCT_ANY,iret)
call codes_new_from_file(ifile, ihandle, CODES_PRODUCT_ANY, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
write(*,*) 'message: ',count
write (*, *) 'message: ', count
! get the product kind
call codes_get(ihandle,'kindOfProduct',product_kind)
write(*,*) ' product: ',product_kind
! get the product kind
call codes_get(ihandle, 'kindOfProduct', product_kind)
write (*, *) ' product: ', product_kind
! release the message
call codes_release(ihandle)
! release the message
call codes_release(ihandle)
! load the next message
call codes_new_from_file(ifile,ihandle,CODES_PRODUCT_ANY,iret)
! load the next message
call codes_new_from_file(ifile, ihandle, CODES_PRODUCT_ANY, iret)
count=count+1
count = count + 1
end do
end do
! close file
call codes_close_file(ifile)
! close file
call codes_close_file(ifile)
end program get_product_kind

86
examples/F90/grib_clone.f90
View File

@ -14,62 +14,62 @@
!
!
program clone
use eccodes
implicit none
integer :: err,i
integer :: nx, ny
integer :: infile,outfile
integer :: igrib_in
integer :: igrib_out
character(len=2) :: step
real(kind=8), dimension(:,:), allocatable :: field2D
use eccodes
implicit none
integer :: err, i
integer :: nx, ny
integer :: infile, outfile
integer :: igrib_in
integer :: igrib_out
character(len=2) :: step
real(kind=8), dimension(:, :), allocatable :: field2D
call codes_open_file(infile,'../../data/constant_field.grib1','r')
call codes_open_file(outfile,'out.clone.grib1','w')
call codes_open_file(infile, '../../data/constant_field.grib1', 'r')
call codes_open_file(outfile, 'out.clone.grib1', 'w')
! A new GRIB message is loaded from file.
! igrib is the GRIB id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib_in)
! A new GRIB message is loaded from file.
! igrib is the GRIB id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib_in)
call codes_get(igrib_in,'Ni', nx)
call codes_get(igrib_in,'Nj', ny)
call codes_get(igrib_in, 'Ni', nx)
call codes_get(igrib_in, 'Nj', ny)
allocate(field2D(nx,ny),stat=err)
allocate (field2D(nx, ny), stat=err)
if (err .ne. 0) then
print*, 'Failed to allocate ', nx*ny, ' values'
STOP
end if
! clone the constant field to create 4 new GRIB messages
do i=0,18,6
call codes_clone(igrib_in, igrib_out)
write(step,'(i2)') i
! Careful: stepRange is a string (could be 0-6, 12-24, etc.)
! use adjustl to remove blank from the left.
call codes_set(igrib_out,'stepRange',adjustl(step))
if (err .ne. 0) then
print *, 'Failed to allocate ', nx*ny, ' values'
STOP
end if
! clone the constant field to create 4 new GRIB messages
do i = 0, 18, 6
call codes_clone(igrib_in, igrib_out)
write (step, '(i2)') i
! Careful: stepRange is a string (could be 0-6, 12-24, etc.)
! use adjustl to remove blank from the left.
call codes_set(igrib_out, 'stepRange', adjustl(step))
call generate_field(field2D)
call generate_field(field2D)
! use pack to create 1D values
call codes_set(igrib_out,'values',pack(field2D, mask=.true.))
! use pack to create 1D values
call codes_set(igrib_out, 'values', pack(field2D, mask=.true.))
! write cloned messages to a file
call codes_write(igrib_out,outfile)
call codes_release(igrib_out)
end do
! write cloned messages to a file
call codes_write(igrib_out, outfile)
call codes_release(igrib_out)
end do
call codes_release(igrib_in)
call codes_close_file(infile)
call codes_close_file(outfile)
deallocate(field2D)
call codes_release(igrib_in)
call codes_close_file(infile)
call codes_close_file(outfile)
deallocate (field2D)
contains
!======================================
subroutine generate_field(gfield2D)
real(kind=8), dimension(:,:) :: gfield2D
subroutine generate_field(gfield2D)
real(kind=8), dimension(:, :) :: gfield2D
call random_number(gfield2D)
end subroutine generate_field
call random_number(gfield2D)
end subroutine generate_field
!======================================
end program clone

59
examples/F90/grib_copy_message.f90
View File

@ -13,44 +13,43 @@
!
!
program copy
use eccodes
implicit none
integer :: err, centre
integer(kind=kindOfSize) :: byte_size
integer :: infile,outfile
integer :: igrib_in
integer :: igrib_out
character(len=1), dimension(:), allocatable :: message
character(len=32) :: product_kind
use eccodes
implicit none
integer :: err, centre
integer(kind=kindOfSize) :: byte_size
integer :: infile, outfile
integer :: igrib_in
integer :: igrib_out
character(len=1), dimension(:), allocatable :: message
character(len=32) :: product_kind
call codes_open_file(infile, '../../data/constant_field.grib1', 'r')
call codes_open_file(outfile, 'out.copy.grib1', 'w')
call codes_open_file(infile,'../../data/constant_field.grib1','r')
call codes_open_file(outfile,'out.copy.grib1','w')
! A new GRIB message is loaded from file
! igrib_in is the GRIB id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib_in)
! A new GRIB message is loaded from file
! igrib_in is the GRIB id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib_in)
call codes_get_message_size(igrib_in, byte_size)
allocate (message(byte_size), stat=err)
call codes_get_message_size(igrib_in, byte_size)
allocate(message(byte_size), stat=err)
call codes_copy_message(igrib_in, message)
call codes_copy_message(igrib_in, message)
call codes_new_from_message(igrib_out, message)
call codes_new_from_message(igrib_out, message)
call codes_get(igrib_out, 'kindOfProduct', product_kind)
write (*, *) 'kindOfProduct=', product_kind
call codes_get(igrib_out, 'kindOfProduct', product_kind)
write(*,*) 'kindOfProduct=',product_kind
centre = 80
call codes_set(igrib_out, 'centre', centre)
centre=80
call codes_set(igrib_out, 'centre', centre)
! Write message to a file
call codes_write(igrib_out, outfile)
! Write message to a file
call codes_write(igrib_out, outfile)
call codes_release(igrib_out)
call codes_release(igrib_in)
call codes_close_file(infile)
call codes_close_file(outfile)
deallocate(message)
call codes_release(igrib_out)
call codes_release(igrib_in)
call codes_close_file(infile)
call codes_close_file(outfile)
deallocate (message)
end program copy

28
examples/F90/grib_copy_namespace.f90
View File

@ -11,26 +11,26 @@
!
!
program copy_namespace
use eccodes
implicit none
integer :: file1, file2, file3
integer :: igrib1,igrib2,igrib3
use eccodes
implicit none
integer :: file1, file2, file3
integer :: igrib1, igrib2, igrib3
call codes_open_file(file1, '../../data/reduced_latlon_surface.grib2', 'r')
call codes_open_file(file2, '../../data/regular_latlon_surface.grib1', 'r')
call codes_open_file(file3, 'out.grib_copy_namespace.grib','w')
call codes_open_file(file1, '../../data/reduced_latlon_surface.grib2', 'r')
call codes_open_file(file2, '../../data/regular_latlon_surface.grib1', 'r')
call codes_open_file(file3, 'out.grib_copy_namespace.grib', 'w')
call codes_grib_new_from_file(file1, igrib1)
call codes_grib_new_from_file(file2, igrib2)
call codes_grib_new_from_file(file1, igrib1)
call codes_grib_new_from_file(file2, igrib2)
call codes_clone(igrib2, igrib3)
call codes_clone(igrib2, igrib3)
call codes_copy_namespace(igrib1, 'geography', igrib3)
call codes_copy_namespace(igrib1, 'geography', igrib3)
call codes_write(igrib3, file3)
call codes_close_file(file1)
call codes_close_file(file2)
call codes_close_file(file3)
call codes_close_file(file1)
call codes_close_file(file2)
call codes_close_file(file3)
end program copy_namespace

153
examples/F90/grib_count_messages.f90
View File

@ -10,101 +10,100 @@
!
!
program get
use eccodes
implicit none
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: n
integer :: i
integer,dimension(:),allocatable :: igrib
real :: latitudeOfFirstPointInDegrees
real :: longitudeOfFirstPointInDegrees
real :: latitudeOfLastPointInDegrees
real :: longitudeOfLastPointInDegrees
integer :: numberOfPointsAlongAParallel
integer :: numberOfPointsAlongAMeridian
real, dimension(:), allocatable :: values
integer :: numberOfValues
real :: average,min_val, max_val
integer :: ifile
integer :: iret
integer :: n
integer :: i
integer, dimension(:), allocatable :: igrib
real :: latitudeOfFirstPointInDegrees
real :: longitudeOfFirstPointInDegrees
real :: latitudeOfLastPointInDegrees
real :: longitudeOfLastPointInDegrees
integer :: numberOfPointsAlongAParallel
integer :: numberOfPointsAlongAMeridian
real, dimension(:), allocatable :: values
integer :: numberOfValues
real :: average, min_val, max_val
call codes_open_file(ifile, &
'../../data/tigge_pf_ecmwf.grib2','r')
call codes_open_file(ifile, &
'../../data/tigge_pf_ecmwf.grib2', 'r')
! count the messages in the file
call codes_count_in_file(ifile,n)
allocate(igrib(n))
igrib=-1
! count the messages in the file
call codes_count_in_file(ifile, n)
allocate (igrib(n))
igrib = -1
! Load the messages from the file.
DO i=1,n
call codes_grib_new_from_file(ifile,igrib(i), iret)
END DO
! Load the messages from the file.
DO i = 1, n
call codes_grib_new_from_file(ifile, igrib(i), iret)
END DO
! we can close the file
call codes_close_file(ifile)
! we can close the file
call codes_close_file(ifile)
! Loop on all the messages in memory
DO i=1,n
write(*,*) 'processing message number ',i
! get as a integer
call codes_get(igrib(i),'Ni',numberOfPointsAlongAParallel)
write(*,*) 'numberOfPointsAlongAParallel=', &
numberOfPointsAlongAParallel
! Loop on all the messages in memory
DO i = 1, n
write (*, *) 'processing message number ', i
! get as a integer
call codes_get(igrib(i), 'Ni', numberOfPointsAlongAParallel)
write (*, *) 'numberOfPointsAlongAParallel=', &
numberOfPointsAlongAParallel
! get as a integer
call codes_get(igrib(i),'Nj',numberOfPointsAlongAMeridian)
write(*,*) 'numberOfPointsAlongAMeridian=', &
numberOfPointsAlongAMeridian
! get as a integer
call codes_get(igrib(i), 'Nj', numberOfPointsAlongAMeridian)
write (*, *) 'numberOfPointsAlongAMeridian=', &
numberOfPointsAlongAMeridian
! get as a real
call codes_get(igrib(i), 'latitudeOfFirstGridPointInDegrees', &
latitudeOfFirstPointInDegrees)
write(*,*) 'latitudeOfFirstGridPointInDegrees=', &
latitudeOfFirstPointInDegrees
! get as a real
call codes_get(igrib(i), 'latitudeOfFirstGridPointInDegrees', &
latitudeOfFirstPointInDegrees)
write (*, *) 'latitudeOfFirstGridPointInDegrees=', &
latitudeOfFirstPointInDegrees
! get as a real
call codes_get(igrib(i), 'longitudeOfFirstGridPointInDegrees', &
longitudeOfFirstPointInDegrees)
write(*,*) 'longitudeOfFirstGridPointInDegrees=', &
! get as a real
call codes_get(igrib(i), 'longitudeOfFirstGridPointInDegrees', &
longitudeOfFirstPointInDegrees)
write (*, *) 'longitudeOfFirstGridPointInDegrees=', &
longitudeOfFirstPointInDegrees
! get as a real
call codes_get(igrib(i), 'latitudeOfLastGridPointInDegrees', &
latitudeOfLastPointInDegrees)
write(*,*) 'latitudeOfLastGridPointInDegrees=', &
! get as a real
call codes_get(igrib(i), 'latitudeOfLastGridPointInDegrees', &
latitudeOfLastPointInDegrees)
write (*, *) 'latitudeOfLastGridPointInDegrees=', &
latitudeOfLastPointInDegrees
! get as a real
call codes_get(igrib(i), 'longitudeOfLastGridPointInDegrees', &
longitudeOfLastPointInDegrees)
write(*,*) 'longitudeOfLastGridPointInDegrees=', &
! get as a real
call codes_get(igrib(i), 'longitudeOfLastGridPointInDegrees', &
longitudeOfLastPointInDegrees)
write (*, *) 'longitudeOfLastGridPointInDegrees=', &
longitudeOfLastPointInDegrees
! get the size of the values array
call codes_get_size(igrib(i), 'values', numberOfValues)
write (*, *) 'numberOfValues=', numberOfValues
! get the size of the values array
call codes_get_size(igrib(i),'values',numberOfValues)
write(*,*) 'numberOfValues=',numberOfValues
allocate (values(numberOfValues), stat=iret)
! get data values
call codes_get(igrib(i), 'values', values)
call codes_get(igrib(i), 'min', min_val) ! can also be obtained through minval(values)
call codes_get(igrib(i), 'max', max_val) ! can also be obtained through maxval(values)
call codes_get(igrib(i), 'average', average) ! can also be obtained through maxval(values)
allocate(values(numberOfValues), stat=iret)
! get data values
call codes_get(igrib(i),'values',values)
call codes_get(igrib(i),'min',min_val) ! can also be obtained through minval(values)
call codes_get(igrib(i),'max',max_val) ! can also be obtained through maxval(values)
call codes_get(igrib(i),'average',average) ! can also be obtained through maxval(values)
write (*, *) 'There are ', numberOfValues, &
' average is ', average, &
' min is ', min_val, &
' max is ', max_val
write (*, *) '---------------------'
deallocate (values)
END DO
write(*,*)'There are ',numberOfValues, &
' average is ',average, &
' min is ', min_val, &
' max is ', max_val
write(*,*) '---------------------'
deallocate(values)
END DO
DO i = 1, n
call codes_release(igrib(i))
END DO
DO i=1,n
call codes_release(igrib(i))
END DO
deallocate(igrib)
deallocate (igrib)
end program get

28
examples/F90/grib_count_messages_multi.f90
View File

@ -10,25 +10,25 @@
!
!
program grib_count_messages_multi
use eccodes
implicit none
use eccodes
implicit none
integer :: ifile
character(len=100) :: grib_file
integer :: n,stat
character(len=1) :: multi_flag
integer :: ifile
character(len=100) :: grib_file
integer :: n, stat
character(len=1) :: multi_flag
call getarg(1,multi_flag)
call getarg(2,grib_file)
call getarg(1, multi_flag)
call getarg(2, grib_file)
if (multi_flag/="0") call codes_grib_multi_support_on()
if (multi_flag /= "0") call codes_grib_multi_support_on()
call codes_open_file(ifile,grib_file,'r')
call codes_open_file(ifile, grib_file, 'r')
! count the messages in the file
call codes_count_in_file(ifile,n,stat)
! count the messages in the file
call codes_count_in_file(ifile, n, stat)
print *,n
print *, n
call codes_close_file(ifile)
call codes_close_file(ifile)
end program grib_count_messages_multi

26
examples/F90/grib_ecc-671.f90
View File

@ -11,23 +11,23 @@
!
USE eccodes
INTEGER :: IGRIBH
CHARACTER (LEN=17) :: CLNOMA1, CLNOMA2
INTEGER :: IGRIBH
CHARACTER(LEN=17) :: CLNOMA1, CLNOMA2
CALL codes_grib_new_from_samples(IGRIBH, "regular_ll_sfc_grib2")
CALL codes_grib_new_from_samples(IGRIBH, "regular_ll_sfc_grib2")
! set centre to MeteoFrance and use their local definition
CALL codes_set (IGRIBH, 'centre', 85)
CALL codes_set (IGRIBH, 'grib2LocalSectionPresent', 1)
CALL codes_set (IGRIBH, 'grib2LocalSectionNumber', 1)
! set centre to MeteoFrance and use their local definition
CALL codes_set(IGRIBH, 'centre', 85)
CALL codes_set(IGRIBH, 'grib2LocalSectionPresent', 1)
CALL codes_set(IGRIBH, 'grib2LocalSectionNumber', 1)
CLNOMA1 = 'SUNSHI. DURATION'
CALL codes_set_string(IGRIBH, 'CLNOMA', CLNOMA1)
CALL codes_get_string(IGRIBH, 'CLNOMA', CLNOMA2)
CLNOMA1 = 'SUNSHI. DURATION'
CALL codes_set_string(IGRIBH, 'CLNOMA', CLNOMA1)
CALL codes_get_string(IGRIBH, 'CLNOMA', CLNOMA2)
PRINT *, " CLNOMA1 = ", CLNOMA1
PRINT *, " CLNOMA2 = ", CLNOMA2
PRINT *, " CLNOMA1 = ", CLNOMA1
PRINT *, " CLNOMA2 = ", CLNOMA2
IF (CLNOMA1 /= CLNOMA2) STOP 1
IF (CLNOMA1 /= CLNOMA2) STOP 1
END

108
examples/F90/grib_get_data.f90
View File

@ -11,71 +11,71 @@
!
!
program get_data
use eccodes
implicit none
integer :: ifile
integer :: iret,i
real(kind=8),dimension(:),allocatable :: lats,lons,values
integer,dimension(:),allocatable :: bitmap
integer(4) :: numberOfPoints
logical :: is_missing_value
integer :: count1=0, count2=0, bitmapPresent=0, bmp_len=0
use eccodes
implicit none
integer :: ifile
integer :: iret, i
real(kind=8), dimension(:), allocatable :: lats, lons, values
integer, dimension(:), allocatable :: bitmap
integer(4) :: numberOfPoints
logical :: is_missing_value
integer :: count1 = 0, count2 = 0, bitmapPresent = 0, bmp_len = 0
! Message identifier.
integer :: igrib
! Message identifier.
integer :: igrib
ifile=5
ifile = 5
call codes_open_file(ifile, &
'../../data/reduced_latlon_surface.grib1','R')
call codes_open_file(ifile, &
'../../data/reduced_latlon_surface.grib1', 'R')
! Loop on all the messages in a file.
call codes_grib_new_from_file(ifile,igrib,iret)
! Loop on all the messages in a file.
call codes_grib_new_from_file(ifile, igrib, iret)
do while (iret/=CODES_END_OF_FILE)
count1=count1+1
print *, "===== Message #",count1
call codes_get(igrib,'numberOfPoints',numberOfPoints)
call codes_get(igrib,'bitmapPresent',bitmapPresent)
do while (iret /= CODES_END_OF_FILE)
count1 = count1 + 1
print *, "===== Message #", count1
call codes_get(igrib, 'numberOfPoints', numberOfPoints)
call codes_get(igrib, 'bitmapPresent', bitmapPresent)
allocate(lats(numberOfPoints))
allocate(lons(numberOfPoints))
allocate(values(numberOfPoints))
if (bitmapPresent == 1) then
! get the bitmap
call codes_get_size(igrib, 'bitmap', bmp_len)
allocate(bitmap(bmp_len))
call codes_get(igrib,'bitmap', bitmap)
end if
call codes_grib_get_data(igrib,lats,lons,values)
do i=1,numberOfPoints
! Consult bitmap to see if the i'th value is missing
is_missing_value=.false.
if (bitmapPresent == 1 .and. bitmap(i) == 0) then
is_missing_value=.true.
allocate (lats(numberOfPoints))
allocate (lons(numberOfPoints))
allocate (values(numberOfPoints))
if (bitmapPresent == 1) then
! get the bitmap
call codes_get_size(igrib, 'bitmap', bmp_len)
allocate (bitmap(bmp_len))
call codes_get(igrib, 'bitmap', bitmap)
end if
! Only print non-missing values
if (.not. is_missing_value) then
print *, lats(i),lons(i),values(i)
count2=count2+1
call codes_grib_get_data(igrib, lats, lons, values)
do i = 1, numberOfPoints
! Consult bitmap to see if the i'th value is missing
is_missing_value = .false.
if (bitmapPresent == 1 .and. bitmap(i) == 0) then
is_missing_value = .true.
end if
! Only print non-missing values
if (.not. is_missing_value) then
print *, lats(i), lons(i), values(i)
count2 = count2 + 1
end if
end do
print *, 'count of non-missing values=', count2
if (count2 /= 214661) then
call codes_check(-2, 'incorrect number of missing', '')
end if
enddo
print *, 'count of non-missing values=',count2
if (count2 /= 214661) then
call codes_check(-2, 'incorrect number of missing', '')
end if
deallocate(lats)
deallocate(lons)
deallocate(values)
deallocate (lats)
deallocate (lons)
deallocate (values)
call codes_release(igrib)
call codes_grib_new_from_file(ifile,igrib, iret)
call codes_release(igrib)
call codes_grib_new_from_file(ifile, igrib, iret)
end do
end do
call codes_close_file(ifile)
call codes_close_file(ifile)
end program

150
examples/F90/grib_get_keys.f90
View File

@ -11,100 +11,100 @@
!
!
program grib_get_keys
use eccodes
implicit none
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: igrib
real :: latitudeOfFirstPointInDegrees
real :: longitudeOfFirstPointInDegrees
real :: latitudeOfLastPointInDegrees
real :: longitudeOfLastPointInDegrees
integer :: numberOfPointsAlongAParallel
integer :: numberOfPointsAlongAMeridian
real, dimension(:), allocatable :: values
integer :: numberOfValues
real :: average,min_val, max_val
integer :: is_missing
character(len=10) :: open_mode='r'
integer :: ifile
integer :: iret
integer :: igrib
real :: latitudeOfFirstPointInDegrees
real :: longitudeOfFirstPointInDegrees
real :: latitudeOfLastPointInDegrees
real :: longitudeOfLastPointInDegrees
integer :: numberOfPointsAlongAParallel
integer :: numberOfPointsAlongAMeridian
real, dimension(:), allocatable :: values
integer :: numberOfValues
real :: average, min_val, max_val
integer :: is_missing
character(len=10) :: open_mode = 'r'
call codes_open_file(ifile, &
'../../data/reduced_latlon_surface.grib1', open_mode)
call codes_open_file(ifile, &
'../../data/reduced_latlon_surface.grib1', open_mode)
! Loop on all the messages in a file.
! Loop on all the messages in a file.
! A new GRIB message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(ifile,igrib, iret)
! A new GRIB message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(ifile, igrib, iret)
LOOP: DO WHILE (iret /= CODES_END_OF_FILE)
LOOP: DO WHILE (iret /= CODES_END_OF_FILE)
! Check if the value of the key is MISSING
is_missing=0;
call codes_is_missing(igrib,'Ni',is_missing);
if ( is_missing /= 1 ) then
! Key value is not missing so get as an integer
call codes_get(igrib,'Ni',numberOfPointsAlongAParallel)
write(*,*) 'numberOfPointsAlongAParallel=', &
numberOfPointsAlongAParallel
else
write(*,*) 'numberOfPointsAlongAParallel is missing'
endif
! Check if the value of the key is MISSING
is_missing = 0;
call codes_is_missing(igrib, 'Ni', is_missing);
if (is_missing /= 1) then
! Key value is not missing so get as an integer
call codes_get(igrib, 'Ni', numberOfPointsAlongAParallel)
write (*, *) 'numberOfPointsAlongAParallel=', &
numberOfPointsAlongAParallel
else
write (*, *) 'numberOfPointsAlongAParallel is missing'
end if
! Get as an integer
call codes_get(igrib,'Nj',numberOfPointsAlongAMeridian)
write(*,*) 'numberOfPointsAlongAMeridian=', &
! Get as an integer
call codes_get(igrib, 'Nj', numberOfPointsAlongAMeridian)
write (*, *) 'numberOfPointsAlongAMeridian=', &
numberOfPointsAlongAMeridian
! Get as a real
call codes_get(igrib, 'latitudeOfFirstGridPointInDegrees', &
latitudeOfFirstPointInDegrees)
write(*,*) 'latitudeOfFirstGridPointInDegrees=', &
latitudeOfFirstPointInDegrees
! Get as a real
call codes_get(igrib, 'latitudeOfFirstGridPointInDegrees', &
latitudeOfFirstPointInDegrees)
write (*, *) 'latitudeOfFirstGridPointInDegrees=', &
latitudeOfFirstPointInDegrees
! Get as a real
call codes_get(igrib, 'longitudeOfFirstGridPointInDegrees', &
longitudeOfFirstPointInDegrees)
write(*,*) 'longitudeOfFirstGridPointInDegrees=', &
longitudeOfFirstPointInDegrees
! Get as a real
call codes_get(igrib, 'longitudeOfFirstGridPointInDegrees', &
longitudeOfFirstPointInDegrees)
write (*, *) 'longitudeOfFirstGridPointInDegrees=', &
longitudeOfFirstPointInDegrees
! Get as a real
call codes_get(igrib, 'latitudeOfLastGridPointInDegrees', &
latitudeOfLastPointInDegrees)
write(*,*) 'latitudeOfLastGridPointInDegrees=', &
latitudeOfLastPointInDegrees
! Get as a real
call codes_get(igrib, 'latitudeOfLastGridPointInDegrees', &
latitudeOfLastPointInDegrees)
write (*, *) 'latitudeOfLastGridPointInDegrees=', &
latitudeOfLastPointInDegrees
! Get as a real
call codes_get(igrib, 'longitudeOfLastGridPointInDegrees', &
longitudeOfLastPointInDegrees)
write(*,*) 'longitudeOfLastGridPointInDegrees=', &
longitudeOfLastPointInDegrees
! Get as a real
call codes_get(igrib, 'longitudeOfLastGridPointInDegrees', &
longitudeOfLastPointInDegrees)
write (*, *) 'longitudeOfLastGridPointInDegrees=', &
longitudeOfLastPointInDegrees
! Get the size of the values array
call codes_get_size(igrib,'values',numberOfValues)
write(*,*) 'numberOfValues=',numberOfValues
! Get the size of the values array
call codes_get_size(igrib, 'values', numberOfValues)
write (*, *) 'numberOfValues=', numberOfValues
allocate(values(numberOfValues), stat=iret)
! Get data values
call codes_get(igrib,'values',values)
call codes_get(igrib,'min',min_val) ! can also be obtained through minval(values)
call codes_get(igrib,'max',max_val) ! can also be obtained through maxval(values)
call codes_get(igrib,'average',average) ! can also be obtained through maxval(values)
allocate (values(numberOfValues), stat=iret)
! Get data values
call codes_get(igrib, 'values', values)
call codes_get(igrib, 'min', min_val) ! can also be obtained through minval(values)
call codes_get(igrib, 'max', max_val) ! can also be obtained through maxval(values)
call codes_get(igrib, 'average', average) ! can also be obtained through maxval(values)
deallocate(values)
deallocate (values)
write(*,*)'There are ',numberOfValues, &
' average is ',average, &
' min is ', min_val, &
' max is ', max_val
write (*, *) 'There are ', numberOfValues, &
' average is ', average, &
' min is ', min_val, &
' max is ', max_val
call codes_release(igrib)
call codes_release(igrib)
call codes_grib_new_from_file(ifile,igrib, iret)
call codes_grib_new_from_file(ifile, igrib, iret)
end do LOOP
end do LOOP
call codes_close_file(ifile)
call codes_close_file(ifile)
end program grib_get_keys

52
examples/F90/grib_get_pl.f90
View File

@ -11,35 +11,35 @@
!
!
program grib_get_pl
use eccodes
implicit none
integer :: infile
integer :: igrib
integer :: PLPresent, nb_pl
real, dimension(:), allocatable :: pl
use eccodes
implicit none
integer :: infile
integer :: igrib
integer :: PLPresent, nb_pl
real, dimension(:), allocatable :: pl
call codes_open_file(infile, &
'../../data/reduced_gaussian_surface.grib1','r')
call codes_open_file(infile, &
'../../data/reduced_gaussian_surface.grib1', 'r')
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib)
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib)
! get PLPresent to see if the 'pl' array is there
call codes_get(igrib,'PLPresent',PLPresent)
print*, "PLPresent= ", PLPresent
if (PLPresent == 1) then
call codes_get_size(igrib,'pl',nb_pl)
print*, "there are ", nb_pl, " PL values"
allocate(pl(nb_pl))
call codes_get(igrib,'pl',pl)
print*, "pl = ", pl
deallocate(pl)
else
print*, "There is no PL values in your GRIB message!"
end if
call codes_release(igrib)
! get PLPresent to see if the 'pl' array is there
call codes_get(igrib, 'PLPresent', PLPresent)
print *, "PLPresent= ", PLPresent
if (PLPresent == 1) then
call codes_get_size(igrib, 'pl', nb_pl)
print *, "there are ", nb_pl, " PL values"
allocate (pl(nb_pl))
call codes_get(igrib, 'pl', pl)
print *, "pl = ", pl
deallocate (pl)
else
print *, "There is no PL values in your GRIB message!"
end if
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(infile)
end program grib_get_pl

52
examples/F90/grib_get_pv.f90
View File

@ -11,35 +11,35 @@
!
!
program grib_get_pv
use eccodes
implicit none
integer :: infile
integer :: igrib
integer :: PVPresent, nb_pv
real, dimension(:), allocatable :: pv
use eccodes
implicit none
integer :: infile
integer :: igrib
integer :: PVPresent, nb_pv
real, dimension(:), allocatable :: pv
call codes_open_file(infile, &
'../../data/reduced_gaussian_model_level.grib1','r')
call codes_open_file(infile, &
'../../data/reduced_gaussian_model_level.grib1', 'r')
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib)
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib)
! Get PVPresent to see if the 'pv' array is there
call codes_get(igrib,'PVPresent',PVPresent)
print*, "PVPresent = ", PVPresent
if (PVPresent == 1) then
call codes_get_size(igrib,'pv',nb_pv)
print*, "There are ", nb_pv, " PV values"
allocate(pv(nb_pv))
call codes_get(igrib,'pv',pv)
print*, "pv = ", pv
deallocate(pv)
else
print*, "There is no PV values in your GRIB message!"
end if
call codes_release(igrib)
! Get PVPresent to see if the 'pv' array is there
call codes_get(igrib, 'PVPresent', PVPresent)
print *, "PVPresent = ", PVPresent
if (PVPresent == 1) then
call codes_get_size(igrib, 'pv', nb_pv)
print *, "There are ", nb_pv, " PV values"
allocate (pv(nb_pv))
call codes_get(igrib, 'pv', pv)
print *, "pv = ", pv
deallocate (pv)
else
print *, "There is no PV values in your GRIB message!"
end if
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(infile)
end program grib_get_pv

146
examples/F90/grib_get_set_uuid.f90
View File

@ -12,89 +12,89 @@
! Original authors: Harald Anlauf, Doerte Liermann (DWD), Luis Kornblueh (MPIfM).
!
program grib_get_set_uuid
use eccodes
implicit none
integer :: infile, outfile
integer :: igrib, ogrib
integer :: count1, i, iret, nvg, ffs, length
character(len=1) :: uuid_in (16) ! Array of 16 bytes for uuid on input.
character(len=1) :: uuid_out(16) ! Array of 16 bytes for uuid on output.
character(len=32) :: uuid_string ! Human-readable uuid.
character(len=32) :: uuid_string_expected ! Expected UUID of input
use eccodes
implicit none
integer :: infile, outfile
integer :: igrib, ogrib
integer :: count1, i, iret, nvg, ffs, length
character(len=1) :: uuid_in(16) ! Array of 16 bytes for uuid on input.
character(len=1) :: uuid_out(16) ! Array of 16 bytes for uuid on output.
character(len=32) :: uuid_string ! Human-readable uuid.
character(len=32) :: uuid_string_expected ! Expected UUID of input
call codes_open_file (infile, '../../data/test_uuid.grib2','r')
call codes_open_file(infile, '../../data/test_uuid.grib2', 'r')
call codes_open_file (outfile, 'out_uuid.grib2','w')
call codes_open_file(outfile, 'out_uuid.grib2', 'w')
! Load first grib message from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file (infile, igrib, iret)
! Load first grib message from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib, iret)
uuid_string_expected = '08b1e836bc6911e1951fb51b5624ad8d'
count1 = 0
do while (iret/=CODES_END_OF_FILE)
count1 = count1 + 1
print *, "### Record:", count1
call codes_get(igrib,'typeOfFirstFixedSurface',ffs)
print *, 'typeOfFirstFixedSurface =', ffs
if (ffs /= 150) then
print *, "Unexpected typeOfFirstFixedSurface (must be 150)."
stop
end if
uuid_string_expected = '08b1e836bc6911e1951fb51b5624ad8d'
count1 = 0
do while (iret /= CODES_END_OF_FILE)
count1 = count1 + 1
print *, "### Record:", count1
call codes_get(igrib, 'typeOfFirstFixedSurface', ffs)
print *, 'typeOfFirstFixedSurface =', ffs
if (ffs /= 150) then
print *, "Unexpected typeOfFirstFixedSurface (must be 150)."
stop
end if
call codes_get (igrib,'numberOfVGridUsed',nvg)
print *, 'numberOfVGridUsed =',nvg
call codes_get(igrib, 'numberOfVGridUsed', nvg)
print *, 'numberOfVGridUsed =', nvg
! call codes_get (igrib,'uuidOfVGrid',uuid_in) ! Assuming length is ok.
call codes_get (igrib,'uuidOfVGrid',uuid_in,length=length)
if (length /= 16) then
print *, "Sorry, bad length of byte_array:", length, ". Expected: 16"
stop
end if
! call codes_get (igrib,'uuidOfVGrid',uuid_in) ! Assuming length is ok.
call codes_get(igrib, 'uuidOfVGrid', uuid_in, length=length)
if (length /= 16) then
print *, "Sorry, bad length of byte_array:", length, ". Expected: 16"
stop
end if
! Convert byte array to hexadecimal string for printing
do i = 1, size (uuid_in)
uuid_string(2*i-1:2*i) = byte2hex(uuid_in(i))
end do
print *, "uuidOfVGrid (on input) = ", uuid_string
if (uuid_string .ne. uuid_string_expected) then
print *, "Sorry, bad value of byte_array. Expected: ", uuid_string_expected
stop
end if
! Convert byte array to hexadecimal string for printing
do i = 1, size(uuid_in)
uuid_string(2*i - 1:2*i) = byte2hex(uuid_in(i))
end do
print *, "uuidOfVGrid (on input) = ", uuid_string
if (uuid_string .ne. uuid_string_expected) then
print *, "Sorry, bad value of byte_array. Expected: ", uuid_string_expected
stop
end if
call codes_clone (igrib,ogrib)
! On output we write a modified uuid (here the input is simply reversed)
uuid_out(1:16) = uuid_in(16:1:-1)
call codes_set (ogrib,'uuidOfVGrid',uuid_out)
call codes_write (ogrib,outfile)
call codes_clone(igrib, ogrib)
! On output we write a modified uuid (here the input is simply reversed)
uuid_out(1:16) = uuid_in(16:1:-1)
call codes_set(ogrib, 'uuidOfVGrid', uuid_out)
call codes_write(ogrib, outfile)
call codes_release (igrib)
call codes_release (ogrib)
call codes_grib_new_from_file (infile, igrib, iret)
end do
call codes_release(igrib)
call codes_release(ogrib)
call codes_grib_new_from_file(infile, igrib, iret)
end do
call codes_close_file (infile)
call codes_close_file (outfile)
call codes_close_file(infile)
call codes_close_file(outfile)
contains
! Convert single byte to 'hexadecimal' string
pure function byte2hex (c) result (hex)
character(len=1), intent(in) :: c
character(len=2) :: hex
integer :: x
x = iachar (c)
hex(1:1) = nibble ( x / 16)
hex(2:2) = nibble (iand (x, 15))
end function byte2hex
! Convert 'nibble' to 'hexadecimal'
pure function nibble (x)
integer, intent(in) :: x
character :: nibble
select case (x)
case (0:9)
nibble = achar (iachar ('0') + x)
case default
nibble = achar (iachar ('a') - 10 + x)
end select
end function nibble
! Convert single byte to 'hexadecimal' string
pure function byte2hex(c) result(hex)
character(len=1), intent(in) :: c
character(len=2) :: hex
integer :: x
x = iachar(c)
hex(1:1) = nibble(x/16)
hex(2:2) = nibble(iand(x, 15))
end function byte2hex
! Convert 'nibble' to 'hexadecimal'
pure function nibble(x)
integer, intent(in) :: x
character :: nibble
select case (x)
case (0:9)
nibble = achar(iachar('0') + x)
case default
nibble = achar(iachar('a') - 10 + x)
end select
end function nibble
end program grib_get_set_uuid

166
examples/F90/grib_index.f90
View File

@ -13,105 +13,105 @@
!
!
program index
use eccodes
implicit none
use eccodes
implicit none
integer :: iret
integer,dimension(:),allocatable :: step,level,number
character(len=20),dimension(:),allocatable :: shortName
integer :: ostep,olevel,onumber
character(len=20) :: oshortName
integer :: shortNameSize,numberSize,levelSize,stepSize
integer :: i,j,k,l
integer :: idx,igrib,count1
character(len=10) :: index_file='index.idx'
integer :: iret
integer, dimension(:), allocatable :: step, level, number
character(len=20), dimension(:), allocatable :: shortName
integer :: ostep, olevel, onumber
character(len=20) :: oshortName
integer :: shortNameSize, numberSize, levelSize, stepSize
integer :: i, j, k, l
integer :: idx, igrib, count1
character(len=10) :: index_file = 'index.idx'
! uncomment following line to load index from file
!call codes_index_read(idx,index_file)
! uncomment following line to load index from file
!call codes_index_read(idx,index_file)
! create an index from a grib file using some keys
call codes_index_create(idx,'../../data/index.grib','shortName,number,level,step')
! create an index from a grib file using some keys
call codes_index_create(idx, '../../data/index.grib', 'shortName,number,level,step')
! get the number of distinct values of shortName in the index
call codes_index_get_size(idx,'shortName',shortNameSize)
! allocate the array to contain the list of distinct shortName
allocate(shortName(shortNameSize))
! get the list of distinct shortName from the index
call codes_index_get(idx,'shortName',shortName)
write(*,'(a,i3)') 'shortNameSize=',shortNameSize
! get the number of distinct values of shortName in the index
call codes_index_get_size(idx, 'shortName', shortNameSize)
! allocate the array to contain the list of distinct shortName
allocate (shortName(shortNameSize))
! get the list of distinct shortName from the index
call codes_index_get(idx, 'shortName', shortName)
write (*, '(a,i3)') 'shortNameSize=', shortNameSize
! get the number of distinct values of number in the index
call codes_index_get_size(idx,'number',numberSize)
! allocate the array to contain the list of distinct numbers
allocate(number(numberSize))
! get the list of distinct numbers from the index
call codes_index_get(idx,'number',number)
write(*,'(a,i3)') 'numberSize=',numberSize
! get the number of distinct values of number in the index
call codes_index_get_size(idx, 'number', numberSize)
! allocate the array to contain the list of distinct numbers
allocate (number(numberSize))
! get the list of distinct numbers from the index
call codes_index_get(idx, 'number', number)
write (*, '(a,i3)') 'numberSize=', numberSize
! get the number of distinct values of level in the index
call codes_index_get_size(idx,'level',levelSize)
! allocate the array to contain the list of distinct levels
allocate(level(levelSize))
! get the list of distinct levels from the index
call codes_index_get(idx,'level',level)
write(*,'(a,i3)') 'levelSize=',levelSize
! get the number of distinct values of level in the index
call codes_index_get_size(idx, 'level', levelSize)
! allocate the array to contain the list of distinct levels
allocate (level(levelSize))
! get the list of distinct levels from the index
call codes_index_get(idx, 'level', level)
write (*, '(a,i3)') 'levelSize=', levelSize
! get the number of distinct values of step in the index
call codes_index_get_size(idx,'step',stepSize)
! allocate the array to contain the list of distinct steps
allocate(step(stepSize))
! get the list of distinct steps from the index
call codes_index_get(idx,'step',step)
write(*,'(a,i3)') 'stepSize=',stepSize
! get the number of distinct values of step in the index
call codes_index_get_size(idx, 'step', stepSize)
! allocate the array to contain the list of distinct steps
allocate (step(stepSize))
! get the list of distinct steps from the index
call codes_index_get(idx, 'step', step)
write (*, '(a,i3)') 'stepSize=', stepSize
count1=0
do l=1,stepSize ! loop on step
! select step=step(l)
call codes_index_select(idx,'step',step(l))
count1 = 0
do l = 1, stepSize ! loop on step
! select step=step(l)
call codes_index_select(idx, 'step', step(l))
do j=1,numberSize ! loop on number
! select number=number(j)
call codes_index_select(idx,'number',number(j))
do j = 1, numberSize ! loop on number
! select number=number(j)
call codes_index_select(idx, 'number', number(j))
do k=1,levelSize ! loop on level
! select level=level(k)
call codes_index_select(idx,'level',level(k))
do k = 1, levelSize ! loop on level
! select level=level(k)
call codes_index_select(idx, 'level', level(k))
do i=1,shortNameSize ! loop on shortName
! select shortName=shortName(i)
call codes_index_select(idx,'shortName',shortName(i))
do i = 1, shortNameSize ! loop on shortName
! select shortName=shortName(i)
call codes_index_select(idx, 'shortName', shortName(i))
call codes_new_from_index(idx,igrib, iret)
do while (iret /= CODES_END_OF_INDEX)
count1=count1+1
call codes_get(igrib,'shortName',oshortName)
call codes_get(igrib,'number',onumber)
call codes_get(igrib,'level',olevel)
call codes_get(igrib,'step',ostep)
write(*,'(A,A,A,i3,A,i4,A,i3)') 'shortName=',trim(oshortName),&
' number=',onumber,&
' level=' ,olevel, &
' step=' ,ostep
call codes_new_from_index(idx, igrib, iret)
do while (iret /= CODES_END_OF_INDEX)
count1 = count1 + 1
call codes_get(igrib, 'shortName', oshortName)
call codes_get(igrib, 'number', onumber)
call codes_get(igrib, 'level', olevel)
call codes_get(igrib, 'step', ostep)
write (*, '(A,A,A,i3,A,i4,A,i3)') 'shortName=', trim(oshortName), &
' number=', onumber, &
' level=', olevel, &
' step=', ostep
call codes_release(igrib)
call codes_new_from_index(idx,igrib, iret)
end do
call codes_release(igrib)
call codes_release(igrib)
call codes_new_from_index(idx, igrib, iret)
end do
call codes_release(igrib)
end do ! loop on step
end do ! loop on level
end do ! loop on number
end do ! loop on shortName
write(*,'(i4,a)') count1,' messages selected'
end do ! loop on step
end do ! loop on level
end do ! loop on number
end do ! loop on shortName
write (*, '(i4,a)') count1, ' messages selected'
! save the index to a file for later reuse
call codes_index_write(idx,index_file)
! save the index to a file for later reuse
call codes_index_write(idx, index_file)
call codes_index_release(idx)
call codes_index_release(idx)
deallocate(level)
deallocate(shortName)
deallocate(step)
deallocate(number)
deallocate (level)
deallocate (shortName)
deallocate (step)
deallocate (number)
end program index

65
examples/F90/grib_keys_iterator.f90
View File

@ -14,50 +14,49 @@
!
!
program keys_iterator
use eccodes
implicit none
character(len=20) :: name_space
integer :: kiter,ifile,igrib,iret
character(len=256) :: key
character(len=256) :: value
character(len=512) :: all1
integer :: grib_count
use eccodes
implicit none
character(len=20) :: name_space
integer :: kiter, ifile, igrib, iret
character(len=256) :: key
character(len=256) :: value
character(len=512) :: all1
integer :: grib_count
call codes_open_file(ifile, &
'../../data/regular_latlon_surface.grib1','r')
call codes_open_file(ifile, &
'../../data/regular_latlon_surface.grib1', 'r')
! Loop on all the messages in a file.
! Loop on all the messages in a file.
call codes_grib_new_from_file(ifile,igrib, iret)
grib_count=0
do while (iret /= CODES_END_OF_FILE)
call codes_grib_new_from_file(ifile, igrib, iret)
grib_count = 0
do while (iret /= CODES_END_OF_FILE)
grib_count=grib_count+1
write(*,*) '-- GRIB N. ',grib_count,' --'
grib_count = grib_count + 1
write (*, *) '-- GRIB N. ', grib_count, ' --'
! valid name_spaces are ls and mars
name_space='ls'
! valid name_spaces are ls and mars
name_space = 'ls'
call codes_keys_iterator_new(igrib,kiter,name_space)
call codes_keys_iterator_new(igrib, kiter, name_space)
do
call codes_keys_iterator_next(kiter, iret)
do
call codes_keys_iterator_next(kiter, iret)
if (iret .ne. CODES_SUCCESS) exit !terminate the loop
if (iret .ne. CODES_SUCCESS) exit !terminate the loop
call codes_keys_iterator_get_name(kiter,key)
call codes_get(igrib,trim(key),value)
all1=trim(key)// ' = ' // trim(value)
write(*,*) trim(all1)
call codes_keys_iterator_get_name(kiter, key)
call codes_get(igrib, trim(key), value)
all1 = trim(key)//' = '//trim(value)
write (*, *) trim(all1)
end do
end do
call codes_keys_iterator_delete(kiter)
call codes_release(igrib)
call codes_grib_new_from_file(ifile,igrib, iret)
end do
call codes_keys_iterator_delete(kiter)
call codes_release(igrib)
call codes_grib_new_from_file(ifile, igrib, iret)
end do
call codes_close_file(ifile)
call codes_close_file(ifile)
end program keys_iterator

38
examples/F90/grib_multi.f90
View File

@ -13,33 +13,33 @@
! For all the tools default is multi support ON.
!
program multi
use eccodes
implicit none
use eccodes
implicit none
integer :: iret
integer(kind = 4) :: step
integer :: ifile,igrib
integer :: iret
integer(kind=4) :: step
integer :: ifile, igrib
call codes_open_file(ifile, '../../data/multi_created.grib2','r')
call codes_open_file(ifile, '../../data/multi_created.grib2', 'r')
! turn on support for multi-field messages */
call codes_grib_multi_support_on()
! turn on support for multi-field messages */
call codes_grib_multi_support_on()
! turn off support for multi-field messages */
!call codes_grib_multi_support_off()
! turn off support for multi-field messages */
!call codes_grib_multi_support_off()
call codes_grib_new_from_file(ifile,igrib, iret)
! Loop on all the messages in a file.
call codes_grib_new_from_file(ifile, igrib, iret)
! Loop on all the messages in a file.
write(*,*) 'step'
do while (iret /= CODES_END_OF_FILE)
write (*, *) 'step'
do while (iret /= CODES_END_OF_FILE)
call codes_get(igrib,'step', step)
write(*,'(i3)') step
call codes_get(igrib, 'step', step)
write (*, '(i3)') step
call codes_grib_new_from_file(ifile,igrib, iret)
call codes_grib_new_from_file(ifile, igrib, iret)
end do
call codes_close_file(ifile)
end do
call codes_close_file(ifile)
end program multi

44
examples/F90/grib_multi_write.f90
View File

@ -15,37 +15,37 @@
!
!
program grib2_multi_write
use eccodes
implicit none
integer :: infile,outfile
integer :: in_gribid
integer :: multi_gribid
integer :: step,startsection
use eccodes
implicit none
integer :: infile, outfile
integer :: in_gribid
integer :: multi_gribid
integer :: step, startsection
! multi field messages can be created only in edition 2
call codes_open_file(infile,'../../data/sample.grib2','r')
! multi field messages can be created only in edition 2
call codes_open_file(infile, '../../data/sample.grib2', 'r')
call codes_open_file(outfile,'multi_created.grib2','w')
call codes_open_file(outfile, 'multi_created.grib2', 'w')
! a grib message is loaded from file
! in_gribid is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile,in_gribid)
! a grib message is loaded from file
! in_gribid is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile, in_gribid)
startsection=4
do step=0,240,12
startsection = 4
do step = 0, 240, 12
call codes_set(in_gribid,"step",step)
call codes_grib_multi_append(in_gribid,startsection,multi_gribid)
call codes_set(in_gribid, "step", step)
call codes_grib_multi_append(in_gribid, startsection, multi_gribid)
enddo
end do
! write messages to a file
call codes_grib_multi_write(multi_gribid,outfile)
call codes_grib_multi_write(multi_gribid, outfile)
call codes_release(in_gribid)
call codes_release(multi_gribid)
call codes_release(in_gribid)
call codes_release(multi_gribid)
call codes_close_file(infile)
call codes_close_file(outfile)
call codes_close_file(infile)
call codes_close_file(outfile)
end program grib2_multi_write

108
examples/F90/grib_nearest.f90
View File

@ -12,67 +12,67 @@
!
!
program find
use eccodes
implicit none
integer :: npoints
integer :: infile
integer :: igrib, ios, i
real(8), dimension(:), allocatable :: lats, lons
real(8), dimension(:), allocatable :: nearest_lats, nearest_lons
real(8), dimension(:), allocatable :: distances, values, lsm_values
integer(kind=kindOfInt), dimension(:), allocatable :: indexes
use eccodes
implicit none
integer :: npoints
integer :: infile
integer :: igrib, ios, i
real(8), dimension(:), allocatable :: lats, lons
real(8), dimension(:), allocatable :: nearest_lats, nearest_lons
real(8), dimension(:), allocatable :: distances, values, lsm_values
integer(kind=kindOfInt), dimension(:), allocatable :: indexes
! initialization
open( unit=1, file="../../data/list_points",form="formatted",action="read")
read(unit=1,fmt=*) npoints
allocate(lats(npoints))
allocate(lons(npoints))
allocate(nearest_lats(npoints))
allocate(nearest_lons(npoints))
allocate(distances(npoints))
allocate(lsm_values(npoints))
allocate(values(npoints))
allocate(indexes(npoints))
do i=1,npoints
read(unit=1,fmt=*, iostat=ios) lats(i), lons(i)
if (ios /= 0) then
npoints = i - 1
exit
end if
end do
close(unit=1)
call codes_open_file(infile, &
'../../data/reduced_gaussian_lsm.grib1','r')
! initialization
open (unit=1, file="../../data/list_points", form="formatted", action="read")
read (unit=1, fmt=*) npoints
allocate (lats(npoints))
allocate (lons(npoints))
allocate (nearest_lats(npoints))
allocate (nearest_lons(npoints))
allocate (distances(npoints))
allocate (lsm_values(npoints))
allocate (values(npoints))
allocate (indexes(npoints))
do i = 1, npoints
read (unit=1, fmt=*, iostat=ios) lats(i), lons(i)
if (ios /= 0) then
npoints = i - 1
exit
end if
end do
close (unit=1)
call codes_open_file(infile, &
'../../data/reduced_gaussian_lsm.grib1', 'r')
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib)
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib)
call codes_grib_find_nearest(igrib, .true., lats, lons, nearest_lats, nearest_lons,lsm_values, distances, indexes)
call codes_release(igrib)
call codes_grib_find_nearest(igrib, .true., lats, lons, nearest_lats, nearest_lons, lsm_values, distances, indexes)
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(infile)
! will apply it to another GRIB
call codes_open_file(infile, &
'../../data/reduced_gaussian_pressure_level.grib1','r')
call codes_grib_new_from_file(infile,igrib)
! will apply it to another GRIB
call codes_open_file(infile, &
'../../data/reduced_gaussian_pressure_level.grib1', 'r')
call codes_grib_new_from_file(infile, igrib)
call codes_get_element(igrib,"values", indexes, values)
call codes_release(igrib)
call codes_close_file(infile)
call codes_get_element(igrib, "values", indexes, values)
call codes_release(igrib)
call codes_close_file(infile)
do i=1, npoints
print*,lats(i), lons(i), nearest_lats(i), nearest_lons(i), distances(i), lsm_values(i), values(i)
end do
do i = 1, npoints
print *, lats(i), lons(i), nearest_lats(i), nearest_lons(i), distances(i), lsm_values(i), values(i)
end do
deallocate(lats)
deallocate(lons)
deallocate(nearest_lats)
deallocate(nearest_lons)
deallocate(distances)
deallocate(lsm_values)
deallocate(values)
deallocate(indexes)
deallocate (lats)
deallocate (lons)
deallocate (nearest_lats)
deallocate (nearest_lons)
deallocate (distances)
deallocate (lsm_values)
deallocate (values)
deallocate (indexes)
end program find

124
examples/F90/grib_precision.f90
View File

@ -13,83 +13,83 @@
!
!
program precision
use eccodes
implicit none
integer(kind = 4) :: size1
integer :: infile,outfile
integer :: igrib
real(kind = 8), dimension(:), allocatable :: values1
real(kind = 8), dimension(:), allocatable :: values2
real(kind = 8) :: maxa,a,maxv,minv,maxr,r
integer( kind = 4) :: decimalPrecision,bitsPerValue1,bitsPerValue2
integer :: i, iret
use eccodes
implicit none
integer(kind=4) :: size1
integer :: infile, outfile
integer :: igrib
real(kind=8), dimension(:), allocatable :: values1
real(kind=8), dimension(:), allocatable :: values2
real(kind=8) :: maxa, a, maxv, minv, maxr, r
integer(kind=4) :: decimalPrecision, bitsPerValue1, bitsPerValue2
integer :: i, iret
call codes_open_file(infile, &
'../../data/regular_latlon_surface_constant.grib1','r')
call codes_open_file(infile, &
'../../data/regular_latlon_surface_constant.grib1', 'r')
call codes_open_file(outfile, &
'../../data/regular_latlon_surface_prec.grib1','w')
call codes_open_file(outfile, &
'../../data/regular_latlon_surface_prec.grib1', 'w')
! a new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib)
! a new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib)
! bitsPerValue before changing the packing parameters
call codes_get(igrib,'bitsPerValue',bitsPerValue1)
! bitsPerValue before changing the packing parameters
call codes_get(igrib, 'bitsPerValue', bitsPerValue1)
! get the size of the values array
call codes_get_size(igrib,"values",size1)
! get the size of the values array
call codes_get_size(igrib, "values", size1)
allocate(values1(size1), stat=iret)
allocate(values2(size1), stat=iret)
! get data values before changing the packing parameters*/
call codes_get(igrib,"values",values1)
allocate (values1(size1), stat=iret)
allocate (values2(size1), stat=iret)
! get data values before changing the packing parameters*/
call codes_get(igrib, "values", values1)
! setting decimal precision=2 means that 2 decimal digits
! are preserved when packing.
decimalPrecision=2
call codes_set(igrib,"changeDecimalPrecision", &
decimalPrecision)
! setting decimal precision=2 means that 2 decimal digits
! are preserved when packing.
decimalPrecision = 2
call codes_set(igrib, "changeDecimalPrecision", &
decimalPrecision)
! bitsPerValue after changing the packing parameters
call codes_get(igrib,"bitsPerValue",bitsPerValue2)
! bitsPerValue after changing the packing parameters
call codes_get(igrib, "bitsPerValue", bitsPerValue2)
! get data values after changing the packing parameters
call codes_get(igrib,"values",values2)
! get data values after changing the packing parameters
call codes_get(igrib, "values", values2)
! computing error
maxa=0
maxr=0
maxv=values2(1)
minv=maxv
do i=1,size1
a=abs(values2(i)-values1(i))
if ( values2(i) .gt. maxv ) maxv=values2(i)
if ( values2(i) .lt. maxv ) minv=values2(i)
if ( values2(i) .ne. 0 ) then
r=abs((values2(i)-values1(i))/values2(i))
endif
if ( a .gt. maxa ) maxa=a
if ( r .gt. maxr ) maxr=r
enddo
write(*,*) "max absolute error = ",maxa
write(*,*) "max relative error = ",maxr
write(*,*) "min value = ",minv
write(*,*) "max value = ",maxv
! computing error
maxa = 0
maxr = 0
maxv = values2(1)
minv = maxv
do i = 1, size1
a = abs(values2(i) - values1(i))
if (values2(i) .gt. maxv) maxv = values2(i)
if (values2(i) .lt. maxv) minv = values2(i)
if (values2(i) .ne. 0) then
r = abs((values2(i) - values1(i))/values2(i))
end if
if (a .gt. maxa) maxa = a
if (r .gt. maxr) maxr = r
end do
write (*, *) "max absolute error = ", maxa
write (*, *) "max relative error = ", maxr
write (*, *) "min value = ", minv
write (*, *) "max value = ", maxv
write(*,*) "old number of bits per value=",bitsPerValue1
write(*,*) "new number of bits per value=",bitsPerValue2
write (*, *) "old number of bits per value=", bitsPerValue1
write (*, *) "new number of bits per value=", bitsPerValue2
! write modified message to a file
call codes_write(igrib,outfile)
! write modified message to a file
call codes_write(igrib, outfile)
call codes_release(igrib)
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(infile)
call codes_close_file(outfile)
call codes_close_file(outfile)
deallocate(values1)
deallocate(values2)
deallocate (values1)
deallocate (values2)
end program precision

70
examples/F90/grib_print_data.f90
View File

@ -12,49 +12,49 @@
!
!
program print_data
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: igrib
integer :: i
real(kind=8), dimension(:), allocatable :: values
integer(kind=4) :: numPoints
real(kind=8) :: average
real(kind=8) :: the_max
real(kind=8) :: the_min
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: igrib
integer :: i
real(kind=8), dimension(:), allocatable :: values
integer(kind=4) :: numPoints
real(kind=8) :: average
real(kind=8) :: the_max
real(kind=8) :: the_min
call codes_open_file(ifile, &
'../../data/constant_field.grib1','r')
call codes_open_file(ifile, &
'../../data/constant_field.grib1', 'r')
! A new GRIB message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(ifile,igrib)
! A new GRIB message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(ifile, igrib)
! Get the size of the values array
call codes_get_size(igrib,'values',numPoints)
! Get the size of the values array
call codes_get_size(igrib, 'values', numPoints)
! Get data values
print*, 'number of points ', numPoints
allocate(values(numPoints), stat=iret)
! Get data values
print *, 'number of points ', numPoints
allocate (values(numPoints), stat=iret)
call codes_get(igrib,'values',values)
call codes_get(igrib, 'values', values)
do i=1,numPoints
write(*,*)' ',i,values(i)
enddo
do i = 1, numPoints
write (*, *) ' ', i, values(i)
end do
write(*,*)numPoints,' values found '
write (*, *) numPoints, ' values found '
call codes_get(igrib,'max',the_max)
write(*,*) 'max=',the_max
call codes_get(igrib,'min',the_min)
write(*,*) 'min=',the_min
call codes_get(igrib,'average',average)
write(*,*) 'average=',average
call codes_get(igrib, 'max', the_max)
write (*, *) 'max=', the_max
call codes_get(igrib, 'min', the_min)
write (*, *) 'min=', the_min
call codes_get(igrib, 'average', average)
write (*, *) 'average=', average
call codes_release(igrib)
call codes_close_file(ifile)
deallocate(values)
call codes_release(igrib)
call codes_close_file(ifile)
deallocate (values)
end program print_data

64
examples/F90/grib_print_data_static.f90
View File

@ -13,46 +13,46 @@
!
!
program print_data
use grib_api
implicit none
integer :: ifile
integer :: igrib
integer :: i
real(kind=8), dimension(99200) :: values_static
integer(kind=4) :: numPoints
real(kind=8) :: average
real(kind=8) :: the_max
real(kind=8) :: the_min
use grib_api
implicit none
integer :: ifile
integer :: igrib
integer :: i
real(kind=8), dimension(99200) :: values_static
integer(kind=4) :: numPoints
real(kind=8) :: average
real(kind=8) :: the_max
real(kind=8) :: the_min
call grib_open_file(ifile, &
'../../data/constant_field.grib1','r')
call grib_open_file(ifile, &
'../../data/constant_field.grib1', 'r')
! A new GRIB message is loaded from file
! igrib is the grib id to be used in subsequent calls
call grib_new_from_file(ifile,igrib)
! A new GRIB message is loaded from file
! igrib is the grib id to be used in subsequent calls
call grib_new_from_file(ifile, igrib)
! Get the size of the values array
call grib_get_size(igrib,'values',numPoints)
! Get the size of the values array
call grib_get_size(igrib, 'values', numPoints)
! Get data values
print*, 'number of points ', numPoints
! Get data values
print *, 'number of points ', numPoints
call grib_get(igrib,'values',values_static)
call grib_get(igrib, 'values', values_static)
do i=1,numPoints
write(*,*)' ',i,values_static(i)
enddo
do i = 1, numPoints
write (*, *) ' ', i, values_static(i)
end do
write(*,*)numPoints,' values found '
write (*, *) numPoints, ' values found '
call grib_get(igrib,'max',the_max)
write(*,*) 'max=',the_max
call grib_get(igrib,'min',the_min)
write(*,*) 'min=',the_min
call grib_get(igrib,'average',average)
write(*,*) 'average=',average
call grib_get(igrib, 'max', the_max)
write (*, *) 'max=', the_max
call grib_get(igrib, 'min', the_min)
write (*, *) 'min=', the_min
call grib_get(igrib, 'average', average)
write (*, *) 'average=', average
call grib_release(igrib)
call grib_close_file(ifile)
call grib_release(igrib)
call grib_close_file(ifile)
end program print_data

48
examples/F90/grib_read_message.f90
View File

@ -9,45 +9,45 @@
! Description: how to get values using keys.
!
program grib_read_message
use eccodes
implicit none
integer :: ifile,ofile
integer :: iret,igrib
integer , dimension(50000) :: buffer
integer(kind=kindOfSize_t) :: len1
integer :: step,level
use eccodes
implicit none
integer :: ifile, ofile
integer :: iret, igrib
integer, dimension(50000) :: buffer
integer(kind=kindOfSize_t) :: len1
integer :: step, level
call codes_open_file(ifile,'../../data/index.grib','r')
call codes_open_file(ofile,'out.readmsg.grib','w')
call codes_open_file(ifile, '../../data/index.grib', 'r')
call codes_open_file(ofile, 'out.readmsg.grib', 'w')
! a grib message is read from file into buffer
len1=size(buffer)*4
call codes_read_from_file(ifile,buffer,len1,iret)
len1 = size(buffer)*4
call codes_read_from_file(ifile, buffer, len1, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
! a new grib message is created from buffer
call codes_new_from_message(igrib,buffer)
call codes_new_from_message(igrib, buffer)
! get as a integer
call codes_get(igrib,'step', step)
write(*,*) 'step=',step
call codes_get(igrib, 'step', step)
write (*, *) 'step=', step
call codes_get(igrib,'level',level)
write(*,*) 'level=',level
call codes_get(igrib, 'level', level)
write (*, *) 'level=', level
call codes_release(igrib)
call codes_release(igrib)
call codes_write_bytes(ofile,buffer,len1)
call codes_write_bytes(ofile, buffer, len1)
! a grib message is read from file into buffer
len1=size(buffer)*4
call codes_read_from_file(ifile,buffer,len1,iret)
len1 = size(buffer)*4
call codes_read_from_file(ifile, buffer, len1, iret)
enddo
end do
call codes_close_file(ifile)
call codes_close_file(ofile)
call codes_close_file(ifile)
call codes_close_file(ofile)
end program grib_read_message

114
examples/F90/grib_samples.f90
View File

@ -11,86 +11,86 @@
!
!
program sample
use eccodes
implicit none
integer :: err
integer :: outfile, datafile
integer :: igribsample,igribclone,igribdata, size1
integer :: date1, startStep, endStep, table2Version, indicatorOfParameter
integer :: decimalPrecision
character(len=10) stepType
real(kind=8), dimension(:), allocatable :: v1,v2,v
use eccodes
implicit none
integer :: err
integer :: outfile, datafile
integer :: igribsample, igribclone, igribdata, size1
integer :: date1, startStep, endStep, table2Version, indicatorOfParameter
integer :: decimalPrecision
character(len=10) stepType
real(kind=8), dimension(:), allocatable :: v1, v2, v
date1 = 20080104
startStep = 0
endStep = 12
stepType = 'accum'
table2Version = 2
indicatorOfParameter = 61
decimalPrecision = 2
date1 = 20080104
startStep = 0
endStep = 12
stepType = 'accum'
table2Version = 2
indicatorOfParameter = 61
decimalPrecision = 2
! A new grib message is loaded from an existing sample.
! Samples are searched in a default sample path (use codes_info
! to see where that is). The default sample path can be changed by
! setting the environment variable ECCODES_SAMPLES_PATH
call codes_grib_new_from_samples(igribsample, "regular_latlon_surface.grib1")
! A new grib message is loaded from an existing sample.
! Samples are searched in a default sample path (use codes_info
! to see where that is). The default sample path can be changed by
! setting the environment variable ECCODES_SAMPLES_PATH
call codes_grib_new_from_samples(igribsample, "regular_latlon_surface.grib1")
call codes_open_file(outfile, 'f_out.samples.grib1','w')
call codes_open_file(datafile,'../../data/tp_ecmwf.grib','r')
call codes_open_file(outfile, 'f_out.samples.grib1', 'w')
call codes_open_file(datafile, '../../data/tp_ecmwf.grib', 'r')
call codes_grib_new_from_file(datafile,igribdata,err)
call codes_grib_new_from_file(datafile, igribdata, err)
call codes_get_size(igribdata,'values',size1)
allocate(v(size1))
allocate(v1(size1))
allocate(v2(size1))
call codes_get_size(igribdata, 'values', size1)
allocate (v(size1))
allocate (v1(size1))
allocate (v2(size1))
call codes_get(igribdata,'values',v)
call codes_get(igribdata, 'values', v)
v=v*1000.0 ! different units for the output grib
v1=v
v = v*1000.0 ! different units for the output grib
v1 = v
do while (err/=CODES_END_OF_FILE)
do while (err /= CODES_END_OF_FILE)
call codes_clone(igribsample,igribclone) ! clone sample before modifying it
call codes_clone(igribsample, igribclone) ! clone sample before modifying it
call codes_set(igribclone,'dataDate',date1)
call codes_set(igribclone,'table2Version',table2Version)
call codes_set(igribclone,'indicatorOfParameter',indicatorOfParameter)
call codes_set(igribclone, 'dataDate', date1)
call codes_set(igribclone, 'table2Version', table2Version)
call codes_set(igribclone, 'indicatorOfParameter', indicatorOfParameter)
call codes_set(igribclone,'stepType',stepType)
call codes_set(igribclone,'startStep',startStep)
call codes_set(igribclone,'endStep',endStep)
call codes_set(igribclone, 'stepType', stepType)
call codes_set(igribclone, 'startStep', startStep)
call codes_set(igribclone, 'endStep', endStep)
call codes_set(igribclone,'decimalPrecision',decimalPrecision)
call codes_set(igribclone, 'decimalPrecision', decimalPrecision)
call codes_set(igribclone,'values',v)
call codes_set(igribclone, 'values', v)
call codes_write(igribclone,outfile)
call codes_write(igribclone, outfile)
call codes_grib_new_from_file(datafile,igribdata,err)
call codes_grib_new_from_file(datafile, igribdata, err)
if (err==0) then
call codes_get(igribdata,'values',v2)
if (err == 0) then
call codes_get(igribdata, 'values', v2)
v2=v2*1000.0 ! different units for the output grib
v2 = v2*1000.0 ! different units for the output grib
v=v2-v1 ! accumulation from startStep to endStep
v = v2 - v1 ! accumulation from startStep to endStep
v1=v2 ! save previous step field
v1 = v2 ! save previous step field
startStep=startStep+12
endStep=endStep+12
startStep = startStep + 12
endStep = endStep + 12
endif
end if
enddo
end do
call codes_release(igribsample)
deallocate(v)
deallocate(v1)
deallocate(v2)
call codes_release(igribsample)
deallocate (v)
deallocate (v1)
deallocate (v2)
call codes_close_file(outfile)
call codes_close_file(outfile)
end program sample

94
examples/F90/grib_set_bitmap.f90
View File

@ -13,67 +13,67 @@
!
!
program set_bitmap
use eccodes
implicit none
integer :: infile,outfile
integer :: igrib, iret
integer :: numberOfValues
real, dimension(:), allocatable :: values
real :: missingValue
logical :: grib1Example
use eccodes
implicit none
integer :: infile, outfile
integer :: igrib, iret
integer :: numberOfValues
real, dimension(:), allocatable :: values
real :: missingValue
logical :: grib1Example
grib1Example=.true.
grib1Example = .true.
if (grib1Example) then
! GRIB 1 example
call codes_open_file(infile,'../../data/regular_latlon_surface.grib1','r')
else
! GRIB 2 example
call codes_open_file(infile,'../../data/regular_latlon_surface.grib2','r')
end if
if (grib1Example) then
! GRIB 1 example
call codes_open_file(infile, '../../data/regular_latlon_surface.grib1', 'r')
else
! GRIB 2 example
call codes_open_file(infile, '../../data/regular_latlon_surface.grib2', 'r')
end if
call codes_open_file(outfile,'out.set_bitmap_f.grib','w')
call codes_open_file(outfile, 'out.set_bitmap_f.grib', 'w')
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib)
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib)
! The missingValue is not coded in the message.
! It is a value we define as a placeholder for a missing value
! at a point in the grid.
! It should be chosen so that it cannot be confused
! with a valid field value
missingValue=9999
call codes_set(igrib, 'missingValue',missingValue)
write(*,*) 'missingValue=',missingValue
! The missingValue is not coded in the message.
! It is a value we define as a placeholder for a missing value
! at a point in the grid.
! It should be chosen so that it cannot be confused
! with a valid field value
missingValue = 9999
call codes_set(igrib, 'missingValue', missingValue)
write (*, *) 'missingValue=', missingValue
! get the size of the values array
call codes_get_size(igrib,'values',numberOfValues)
write(*,*) 'numberOfValues=',numberOfValues
! get the size of the values array
call codes_get_size(igrib, 'values', numberOfValues)
write (*, *) 'numberOfValues=', numberOfValues
allocate(values(numberOfValues), stat=iret)
allocate (values(numberOfValues), stat=iret)
! get data values
call codes_get(igrib,'values',values)
! get data values
call codes_get(igrib, 'values', values)
! enable bitmap
call codes_set(igrib, 'bitmapPresent', 1)
! enable bitmap
call codes_set(igrib, 'bitmapPresent', 1)
! set some values to be missing
values(1:10) = missingValue
! set some values to be missing
values(1:10) = missingValue
! set the values (the bitmap will be automatically built)
call codes_set(igrib,'values', values)
! set the values (the bitmap will be automatically built)
call codes_set(igrib, 'values', values)
! write modified message to a file
call codes_write(igrib,outfile)
! write modified message to a file
call codes_write(igrib, outfile)
! free memory
call codes_release(igrib)
! free memory
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(outfile)
call codes_close_file(infile)
call codes_close_file(outfile)
deallocate(values)
deallocate (values)
end program set_bitmap

80
examples/F90/grib_set_data.f90
View File

@ -13,51 +13,51 @@
! If there are missing values, refer to: grib_set_bitmap
!
program set_data
use eccodes
implicit none
integer :: outfile
integer :: i, igrib, iret, numberOfValues, cnt
real :: d, e
real, dimension(:), allocatable :: values
integer, parameter :: max_strsize = 200
character(len=max_strsize) :: outfile_name
use eccodes
implicit none
integer :: outfile
integer :: i, igrib, iret, numberOfValues, cnt
real :: d, e
real, dimension(:), allocatable :: values
integer, parameter :: max_strsize = 200
character(len=max_strsize) :: outfile_name
call getarg(1, outfile_name)
call codes_open_file(outfile,outfile_name,'w')
call getarg(1, outfile_name)
call codes_open_file(outfile, outfile_name, 'w')
! Note: the full name of the sample file is "regular_ll_pl_grib1.tmpl"
! Sample files are stored in the samples directory (use codes_info to
! see where that is). The default sample path can be changed by
! setting the environment variable ECCODES_SAMPLES_PATH
call codes_grib_new_from_samples(igrib, 'regular_ll_pl_grib1')
! Note: the full name of the sample file is "regular_ll_pl_grib1.tmpl"
! Sample files are stored in the samples directory (use codes_info to
! see where that is). The default sample path can be changed by
! setting the environment variable ECCODES_SAMPLES_PATH
call codes_grib_new_from_samples(igrib, 'regular_ll_pl_grib1')
! Here we're changing the data values only, so the number of values
! will be the same as the sample GRIB.
! But if your data array has a different size, then specify the grid geometry
! (e.g. keys Ni, Nj etc) and set the correct number of data values
call codes_get_size(igrib,'values',numberOfValues)
! Here we're changing the data values only, so the number of values
! will be the same as the sample GRIB.
! But if your data array has a different size, then specify the grid geometry
! (e.g. keys Ni, Nj etc) and set the correct number of data values
call codes_get_size(igrib, 'values', numberOfValues)
allocate(values(numberOfValues), stat=iret)
d = 10e-8
e = d
cnt = 1
do i=1,numberOfValues
if (cnt>100) then
e = e*10
cnt=1
endif
values(i) = d
!print *, values(i)
d = d + e
cnt = cnt + 1
end do
allocate (values(numberOfValues), stat=iret)
d = 10e-8
e = d
cnt = 1
do i = 1, numberOfValues
if (cnt > 100) then
e = e*10
cnt = 1
end if
values(i) = d
!print *, values(i)
d = d + e
cnt = cnt + 1
end do
call codes_set(igrib, 'bitsPerValue', 16)
call codes_set(igrib, 'bitsPerValue', 16)
! set data values
call codes_set(igrib,'values', values)
call codes_write(igrib,outfile)
call codes_release(igrib)
deallocate(values)
! set data values
call codes_set(igrib, 'values', values)
call codes_write(igrib, outfile)
call codes_release(igrib)
deallocate (values)
end program set_data

68
examples/F90/grib_set_gvc.f90
View File

@ -13,55 +13,55 @@
!
!
program set
use eccodes
implicit none
integer :: infile,outfile
integer :: igrib
use eccodes
implicit none
integer :: infile, outfile
integer :: igrib
call codes_open_file(infile, '../../data/sample.grib2','r')
call codes_open_file(infile, '../../data/sample.grib2', 'r')
call codes_open_file(outfile, 'out_gvc.grib2','w')
call codes_open_file(outfile, 'out_gvc.grib2', 'w')
call codes_grib_new_from_file(infile,igrib)
call codes_grib_new_from_file(infile, igrib)
! Individual ensemble forecast
call codes_set(igrib,'productDefinitionTemplateNumber', 11)
! Individual ensemble forecast
call codes_set(igrib, 'productDefinitionTemplateNumber', 11)
! Select level type as Generalized Vertical Height Coordinate
call codes_set(igrib,'typeOfLevel', 'generalVertical')
! Select level type as Generalized Vertical Height Coordinate
call codes_set(igrib, 'typeOfLevel', 'generalVertical')
! Now set keys specific to this level type
call codes_set(igrib,'nlev', 12.21)
call codes_set(igrib,'numberOfVGridUsed', 13.55)
! Now set keys specific to this level type
call codes_set(igrib, 'nlev', 12.21)
call codes_set(igrib, 'numberOfVGridUsed', 13.55)
! check integrity of GRIB message
call check_settings(igrib)
! check integrity of GRIB message
call check_settings(igrib)
! write modified message to a file
call codes_write(igrib,outfile)
! write modified message to a file
call codes_write(igrib, outfile)
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(outfile)
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(outfile)
contains
!======================================
subroutine check_settings(gribid)
implicit none
integer, intent(in) :: gribid
subroutine check_settings(gribid)
implicit none
integer, intent(in) :: gribid
integer(kind = 4) :: NV,typeOfFirstFixedSurface
integer(kind=4) :: NV, typeOfFirstFixedSurface
call codes_get(gribid,'NV', NV)
if (NV /= 6) then
call codes_check(-2, 'NV_should_be_6', '')
end if
call codes_get(gribid, 'NV', NV)
if (NV /= 6) then
call codes_check(-2, 'NV_should_be_6', '')
end if
call codes_get(gribid,'typeOfFirstFixedSurface', typeOfFirstFixedSurface)
if (typeOfFirstFixedSurface /= 150) then
call codes_check(-2, 'typeOfFirstFixedSurface_should_be_150', '')
end if
call codes_get(gribid, 'typeOfFirstFixedSurface', typeOfFirstFixedSurface)
if (typeOfFirstFixedSurface /= 150) then
call codes_check(-2, 'typeOfFirstFixedSurface_should_be_150', '')
end if
end subroutine check_settings
end subroutine check_settings
end program set

90
examples/F90/grib_set_keys.f90
View File

@ -11,69 +11,69 @@
!
!
program set
use eccodes
implicit none
integer(kind = 4) :: centre, date1
integer :: infile,outfile
integer :: igrib
character(len=12) :: marsType = 'ses'
use eccodes
implicit none
integer(kind=4) :: centre, date1
integer :: infile, outfile
integer :: igrib
character(len=12) :: marsType = 'ses'
centre = 80
call current_date(date1)
call codes_open_file(infile, '../../data/regular_latlon_surface_constant.grib1','r')
call codes_open_file(outfile, 'out.set.grib1','w')
centre = 80
call current_date(date1)
call codes_open_file(infile, '../../data/regular_latlon_surface_constant.grib1', 'r')
call codes_open_file(outfile, 'out.set.grib1', 'w')
! A new GRIB message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib)
! A new GRIB message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib)
call codes_set(igrib,'dataDate',date1)
call codes_set(igrib,'type', marsType)
call codes_set(igrib, 'dataDate', date1)
call codes_set(igrib, 'type', marsType)
! set centre as a integer */
call codes_set(igrib,'centre',centre)
! set centre as a integer */
call codes_set(igrib, 'centre', centre)
! Check if it is correct in the actual GRIB message
call check_settings(igrib)
! Check if it is correct in the actual GRIB message
call check_settings(igrib)
! Write modified message to a file
call codes_write(igrib,outfile)
! Write modified message to a file
call codes_write(igrib, outfile)
call codes_release(igrib)
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(outfile)
call codes_close_file(infile)
call codes_close_file(outfile)
contains
!======================================
subroutine current_date(date1)
integer, intent(out) :: date1
subroutine current_date(date1)
integer, intent(out) :: date1
integer :: val_date(8)
call date_and_time ( values = val_date)
integer :: val_date(8)
call date_and_time(values=val_date)
date1 = val_date(1)* 10000 + val_date(2)*100 + val_date(3)
end subroutine current_date
date1 = val_date(1)*10000 + val_date(2)*100 + val_date(3)
end subroutine current_date
!======================================
subroutine check_settings(gribid)
implicit none
integer, intent(in) :: gribid
subroutine check_settings(gribid)
implicit none
integer, intent(in) :: gribid
integer(kind = 4) :: int_value
character(len = 10) :: string_value
integer(kind=4) :: int_value
character(len=10) :: string_value
! get centre as a integer
call codes_get(gribid,'centre',int_value)
write(*,*) "get centre as a integer - centre = ",int_value
! get centre as a integer
call codes_get(gribid, 'centre', int_value)
write (*, *) "get centre as a integer - centre = ", int_value
! get centre as a string
call codes_get(gribid,'centre',string_value)
write(*,*) "get centre as a string - centre = ",string_value
! get centre as a string
call codes_get(gribid, 'centre', string_value)
write (*, *) "get centre as a string - centre = ", string_value
! get date as a string
call codes_get(gribid,'dataDate',string_value)
write(*,*) "get date as a string - date = ",string_value
! get date as a string
call codes_get(gribid, 'dataDate', string_value)
write (*, *) "get date as a string - date = ", string_value
end subroutine check_settings
end subroutine check_settings
end program set

56
examples/F90/grib_set_missing.f90
View File

@ -13,40 +13,40 @@
!
!
program set
use eccodes
implicit none
integer :: infile,outfile
integer :: igrib, Ni, is_missing
use eccodes
implicit none
integer :: infile, outfile
integer :: igrib, Ni, is_missing
infile=5
outfile=6
infile = 5
outfile = 6
call codes_open_file(infile, &
'../../data/reduced_gaussian_pressure_level.grib2','r')
call codes_open_file(infile, &
'../../data/reduced_gaussian_pressure_level.grib2', 'r')
call codes_open_file(outfile, &
'f_out_surface_level.grib2','w')
call codes_open_file(outfile, &
'f_out_surface_level.grib2', 'w')
! a new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib)
! a new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib)
call codes_set(igrib,'typeOfFirstFixedSurface','sfc')
call codes_set_missing(igrib,'scaleFactorOfFirstFixedSurface')
call codes_set_missing(igrib,'scaledValueOfFirstFixedSurface')
call codes_set(igrib, 'typeOfFirstFixedSurface', 'sfc')
call codes_set_missing(igrib, 'scaleFactorOfFirstFixedSurface')
call codes_set_missing(igrib, 'scaledValueOfFirstFixedSurface')
! See GRIB-490
call codes_get(igrib, 'Ni', Ni)
call codes_is_missing(igrib,'Ni',is_missing)
if ( is_missing == 0 ) then
! Ni should be missing in gribs with Reduced Gaussian grids
call codes_check(-2, 'Ni_should_be_missing', '')
endif
call codes_set(igrib, 'Ni', Ni)
! See GRIB-490
call codes_get(igrib, 'Ni', Ni)
call codes_is_missing(igrib, 'Ni', is_missing)
if (is_missing == 0) then
! Ni should be missing in gribs with Reduced Gaussian grids
call codes_check(-2, 'Ni_should_be_missing', '')
end if
call codes_set(igrib, 'Ni', Ni)
call codes_write(igrib,outfile)
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(outfile)
call codes_write(igrib, outfile)
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(outfile)
end program set

66
examples/F90/grib_set_packing.f90
View File

@ -10,45 +10,45 @@
! e.g. Simple packing, CCSDS
!
program set_packing
use eccodes
implicit none
integer :: outfile
integer :: i, igrib, iret, numberOfValues, cnt
real :: d, e
real, dimension(:), allocatable :: values
integer, parameter :: max_strsize = 200
character(len=max_strsize) :: outfile_name, packing_type
use eccodes
implicit none
integer :: outfile
integer :: i, igrib, iret, numberOfValues, cnt
real :: d, e
real, dimension(:), allocatable :: values
integer, parameter :: max_strsize = 200
character(len=max_strsize) :: outfile_name, packing_type
call getarg(1, packing_type)
call getarg(2, outfile_name)
call getarg(1, packing_type)
call getarg(2, outfile_name)
call codes_open_file(outfile,outfile_name,'w')
call codes_open_file(outfile, outfile_name, 'w')
call codes_grib_new_from_samples(igrib, 'gg_sfc_grib2')
call codes_grib_new_from_samples(igrib, 'gg_sfc_grib2')
call codes_get_size(igrib,'values', numberOfValues)
allocate(values(numberOfValues), stat=iret)
d = 10e-6
e = d
cnt = 1
do i=1,numberOfValues
if (cnt>100) then
e = e*1.01
cnt=1
endif
values(i) = d
d = d + e
cnt = cnt + 1
end do
call codes_get_size(igrib, 'values', numberOfValues)
allocate (values(numberOfValues), stat=iret)
d = 10e-6
e = d
cnt = 1
do i = 1, numberOfValues
if (cnt > 100) then
e = e*1.01
cnt = 1
end if
values(i) = d
d = d + e
cnt = cnt + 1
end do
call codes_set(igrib, 'numberOfBitsContainingEachPackedValue', 16)
call codes_set(igrib, 'packingType', packing_type)
call codes_set(igrib, 'numberOfBitsContainingEachPackedValue', 16)
call codes_set(igrib, 'packingType', packing_type)
! set data values
call codes_set(igrib, 'values', values)
! set data values
call codes_set(igrib, 'values', values)
call codes_write(igrib, outfile)
call codes_release(igrib)
deallocate(values)
call codes_write(igrib, outfile)
call codes_release(igrib)
deallocate (values)
end program set_packing

84
examples/F90/grib_set_pv.f90
View File

@ -12,62 +12,62 @@
!
!
program grib_set_pv
use eccodes
implicit none
integer :: numberOfLevels
integer :: numberOfCoefficients
integer :: outfile, igrib
integer :: i, ios
real, dimension(:),allocatable :: pv
use eccodes
implicit none
integer :: numberOfLevels
integer :: numberOfCoefficients
integer :: outfile, igrib
integer :: i, ios
real, dimension(:), allocatable :: pv
numberOfLevels=60
numberOfCoefficients=2*(numberOfLevels+1)
numberOfLevels = 60
numberOfCoefficients = 2*(numberOfLevels + 1)
allocate(pv(numberOfCoefficients))
allocate (pv(numberOfCoefficients))
! read the model level coefficients from file
open( unit=1, file="../../data/60_model_levels", &
form="formatted",action="read")
! read the model level coefficients from file
open (unit=1, file="../../data/60_model_levels", &
form="formatted", action="read")
do i=1,numberOfCoefficients,2
read(unit=1,fmt=*, iostat=ios) pv(i), pv(i+1)
if (ios /= 0) then
print *, "I/O error: ",ios
exit
end if
end do
do i = 1, numberOfCoefficients, 2
read (unit=1, fmt=*, iostat=ios) pv(i), pv(i + 1)
if (ios /= 0) then
print *, "I/O error: ", ios
exit
end if
end do
! print coefficients
!do i=1,numberOfCoefficients,2
! print *," a=",pv(i)," b=",pv(i+1)
!end do
! print coefficients
!do i=1,numberOfCoefficients,2
! print *," a=",pv(i)," b=",pv(i+1)
!end do
close(unit=1)
close (unit=1)
call codes_open_file(outfile, 'out.pv.grib1','w')
call codes_open_file(outfile, 'out.pv.grib1', 'w')
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_samples(igrib, "reduced_gg_sfc_grib1")
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_samples(igrib, "reduced_gg_sfc_grib1")
! set levtype to ml (model level)
call codes_set(igrib,'typeOfLevel','hybrid')
! set levtype to ml (model level)
call codes_set(igrib, 'typeOfLevel', 'hybrid')
! set level
call codes_set(igrib,'level',2)
! set level
call codes_set(igrib, 'level', 2)
! set PVPresent as an integer
call codes_set(igrib,'PVPresent',1)
! set PVPresent as an integer
call codes_set(igrib, 'PVPresent', 1)
call codes_set(igrib,'pv',pv)
call codes_set(igrib, 'pv', pv)
! write modified message to a file
call codes_write(igrib,outfile)
! write modified message to a file
call codes_write(igrib, outfile)
! Free memory
call codes_release(igrib)
deallocate(pv)
! Free memory
call codes_release(igrib)
deallocate (pv)
call codes_close_file(outfile)
call codes_close_file(outfile)
end program grib_set_pv

66
examples/F90/iterator_fortran.f90
View File

@ -11,60 +11,60 @@
!
!
program iterator
use eccodes
implicit none
integer :: ifile
integer :: iret,iter
real(kind=8) :: lat,lon,value,missingValue
integer :: n,flags
use eccodes
implicit none
integer :: ifile
integer :: iret, iter
real(kind=8) :: lat, lon, value, missingValue
integer :: n, flags
! Message identifier.
integer :: igrib
! Message identifier.
integer :: igrib
ifile=5
ifile = 5
call codes_open_file(ifile, &
'../../data/regular_latlon_surface_constant.grib1','R')
call codes_open_file(ifile, &
'../../data/regular_latlon_surface_constant.grib1', 'R')
! Loop on all the messages in a file.
call codes_grib_new_from_file(ifile,igrib,iret)
! Loop on all the messages in a file.
call codes_grib_new_from_file(ifile, igrib, iret)
LOOP: DO WHILE (iret/=CODES_END_OF_FILE)
LOOP: DO WHILE (iret /= CODES_END_OF_FILE)
! get as a real8
call codes_get(igrib, &
'missingValue',missingValue)
write(*,*) 'missingValue=',missingValue
'missingValue', missingValue)
write (*, *) 'missingValue=', missingValue
! A new iterator on lat/lon/values is created from the message igrib
flags = 0
call grib_iterator_new(igrib,iter,flags)
call grib_iterator_new(igrib, iter, flags)
n = 0
! Loop on all the lat/lon/values.
call grib_iterator_next(iter,lat,lon,value, iret)
call grib_iterator_next(iter, lat, lon, value, iret)
do while (iret .ne. 0)
! You can now print lat and lon,
if ( value .eq. missingValue ) then
! decide what to print if a missing value is found.
write(*,*) "- ",n," - lat=",lat," lon=",lon," value=missing"
if (value .eq. missingValue) then
! decide what to print if a missing value is found.
write (*, *) "- ", n, " - lat=", lat, " lon=", lon, " value=missing"
else
! or print the value if is not missing.
write(*,*) " ",n," lat=",lat," lon=",lon," value=",value
endif
! or print the value if is not missing.
write (*, *) " ", n, " lat=", lat, " lon=", lon, " value=", value
end if
n=n+1
n = n + 1
call grib_iterator_next(iter,lat,lon,value, iret)
call grib_iterator_next(iter, lat, lon, value, iret)
end do
! At the end the iterator is deleted to free memory.
call grib_iterator_delete(iter)
call codes_release(igrib)
! At the end the iterator is deleted to free memory.
call grib_iterator_delete(iter)
call codes_release(igrib)
call codes_grib_new_from_file(ifile,igrib, iret)
call codes_grib_new_from_file(ifile, igrib, iret)
end do LOOP
end do LOOP
call codes_close_file(ifile)
call codes_close_file(ifile)
end program iterator
end program iterator

72
examples/F90/keys_iterator_fortran.f90
View File

@ -14,55 +14,55 @@
!
!
program keys_iterator
use eccodes
implicit none
integer :: kiter,ifile,igrib,iret
character(len=256) :: key
character(len=256) :: value
character(len=2048) :: all
integer :: len
integer :: grib_count
len=256
use eccodes
implicit none
integer :: kiter, ifile, igrib, iret
character(len=256) :: key
character(len=256) :: value
character(len=2048) :: all
integer :: len
integer :: grib_count
len = 256
ifile=5
ifile = 5
call codes_open_file(ifile, &
'../../data/regular_latlon_surface.grib1','r')
call codes_open_file(ifile, &
'../../data/regular_latlon_surface.grib1', 'r')
grib_count=0
! Loop on all the messages in a file.
grib_count = 0
! Loop on all the messages in a file.
call codes_grib_new_from_file(ifile,igrib)
call codes_grib_new_from_file(ifile, igrib)
do while (igrib .ne. -1)
do while (igrib .ne. -1)
grib_count=grib_count+1
write(*,'("-- GRIB N.",I4," --")') grib_count
grib_count = grib_count + 1
write (*, '("-- GRIB N.",I4," --")') grib_count
! valid name_spaces are ls and mars
call codes_keys_iterator_new(igrib,kiter,'ls')
! valid name_spaces are ls and mars
call codes_keys_iterator_new(igrib, kiter, 'ls')
if (kiter .eq. -1) then
print *, 'invalid key iterator'
endif
if (kiter .eq. -1) then
print *, 'invalid key iterator'
end if
do
call codes_keys_iterator_next(kiter, iret)
do
call codes_keys_iterator_next(kiter, iret)
if (iret .ne. CODES_SUCCESS) exit
if (iret .ne. CODES_SUCCESS) exit
call codes_keys_iterator_get_name(kiter,key)
call codes_keys_iterator_get_name(kiter, key)
call codes_get(igrib,key,value)
all='|'//trim(key)//'|'//' = '//'|'//trim(value)//'|'
write(*,*) trim(all)
call codes_get(igrib, key, value)
all = '|'//trim(key)//'|'//' = '//'|'//trim(value)//'|'
write (*, *) trim(all)
end do
call codes_keys_iterator_delete(kiter)
call codes_release(igrib)
call codes_grib_new_from_file(ifile, igrib, iret)
end do
call codes_keys_iterator_delete(kiter)
call codes_release(igrib)
call codes_grib_new_from_file(ifile,igrib, iret)
end do
call codes_close_file(ifile)
call codes_close_file(ifile)
end program keys_iterator

72
examples/F90/multi_fortran.f90
View File

@ -14,53 +14,53 @@
!
!
program multi
use eccodes
implicit none
use eccodes
implicit none
integer :: iret
integer(kind = 4) :: parameterCategory,parameterNumber,discipline
integer :: ifile,igrib
integer :: iret
integer(kind=4) :: parameterCategory, parameterNumber, discipline
integer :: ifile, igrib
call codes_open_file(ifile, '../../data/multi.grib2','r')
call codes_open_file(ifile, '../../data/multi.grib2', 'r')
! turn on support for multi fields messages */
call codes_grib_multi_support_on()
! turn on support for multi fields messages */
call codes_grib_multi_support_on()
! turn off support for multi fields messages */
!call codes_grib_multi_support_off()
! turn off support for multi fields messages */
!call codes_grib_multi_support_off()
call codes_grib_new_from_file(ifile,igrib)
! Loop on all the messages in a file.
call codes_grib_new_from_file(ifile, igrib)
! Loop on all the messages in a file.
do while (igrib .ne. -1)
do while (igrib .ne. -1)
! get as a integer*4
call codes_get(igrib,'discipline',discipline)
write(*,*) 'discipline=',discipline
! get as a integer*4
call codes_get(igrib, 'discipline', discipline)
write (*, *) 'discipline=', discipline
! get as a integer*4
call codes_get(igrib,'parameterCategory', &
parameterCategory)
write(*,*) 'parameterCategory=',parameterCategory
! get as a integer*4
call codes_get(igrib, 'parameterCategory', &
parameterCategory)
write (*, *) 'parameterCategory=', parameterCategory
! get as a integer*4
call codes_get(igrib,'parameterNumber', &
parameterNumber)
write(*,*) 'parameterNumber=',parameterNumber
! get as a integer*4
call codes_get(igrib, 'parameterNumber', &
parameterNumber)
write (*, *) 'parameterNumber=', parameterNumber
if ( discipline .eq. 0 .and. parameterCategory .eq. 2) then
if (parameterNumber .eq. 2) then
write(*,*) "-------- u -------"
endif
if (parameterNumber .eq. 3) then
write(*,*) "-------- v -------"
endif
endif
if (discipline .eq. 0 .and. parameterCategory .eq. 2) then
if (parameterNumber .eq. 2) then
write (*, *) "-------- u -------"
end if
if (parameterNumber .eq. 3) then
write (*, *) "-------- v -------"
end if
end if
call codes_release(igrib)
call codes_grib_new_from_file(ifile,igrib, iret)
call codes_release(igrib)
call codes_grib_new_from_file(ifile, igrib, iret)
end do
call codes_close_file(ifile)
end do
call codes_close_file(ifile)
end program multi

41
examples/F90/new_from_file.f90
View File

@ -9,33 +9,32 @@
!
!
program new_from_file
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: count1=0
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: count1 = 0
! Message identifier.
integer :: igrib
! Message identifier.
integer :: igrib
ifile=5
ifile = 5
call codes_open_file(ifile,'../../data/collection.grib1','r')
call codes_open_file(ifile, '../../data/collection.grib1', 'r')
! Loop on all the messages in a file.
call codes_grib_new_from_file(ifile,igrib, iret)
! Loop on all the messages in a file.
call codes_grib_new_from_file(ifile, igrib, iret)
do while (iret==CODES_SUCCESS)
count1=count1+1
print *, "===== Message #",count1
call codes_grib_new_from_file(ifile,igrib, iret)
do while (iret == CODES_SUCCESS)
count1 = count1 + 1
print *, "===== Message #", count1
call codes_grib_new_from_file(ifile, igrib, iret)
end do
if (iret /= CODES_END_OF_FILE) then
call codes_check(iret,'new_from_file','')
endif
end do
if (iret /= CODES_END_OF_FILE) then
call codes_check(iret, 'new_from_file', '')
end if
call codes_close_file(ifile)
call codes_close_file(ifile)
end program

124
examples/F90/precision_fortran.f90
View File

@ -11,82 +11,82 @@
!
!
program precision
use eccodes
implicit none
integer(kind = 4) :: size
integer :: infile,outfile
integer :: igrib
real(kind = 8), dimension(:), allocatable :: values1
real(kind = 8), dimension(:), allocatable :: values2
real(kind = 8) :: maxa,a,maxv,minv,maxr,r
integer( kind = 4) :: decimalPrecision,bitsPerValue1,bitsPerValue2
integer :: i, iret
use eccodes
implicit none
integer(kind=4) :: size
integer :: infile, outfile
integer :: igrib
real(kind=8), dimension(:), allocatable :: values1
real(kind=8), dimension(:), allocatable :: values2
real(kind=8) :: maxa, a, maxv, minv, maxr, r
integer(kind=4) :: decimalPrecision, bitsPerValue1, bitsPerValue2
integer :: i, iret
call codes_open_file(infile, &
'../../data/regular_latlon_surface_constant.grib1','r')
call codes_open_file(infile, &
'../../data/regular_latlon_surface_constant.grib1', 'r')
call codes_open_file(outfile, &
'../../data/regular_latlon_surface_prec.grib1','w')
call codes_open_file(outfile, &
'../../data/regular_latlon_surface_prec.grib1', 'w')
! a new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib)
! a new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib)
! bitsPerValue before changing the packing parameters
call codes_get(igrib,'bitsPerValue',bitsPerValue1)
! bitsPerValue before changing the packing parameters
call codes_get(igrib, 'bitsPerValue', bitsPerValue1)
! get the size of the values array
call codes_get_size(igrib,"values",size)
! get the size of the values array
call codes_get_size(igrib, "values", size)
allocate(values1(size), stat=iret)
allocate(values2(size), stat=iret)
! get data values before changing the packing parameters*/
call codes_get(igrib,"values",values1)
allocate (values1(size), stat=iret)
allocate (values2(size), stat=iret)
! get data values before changing the packing parameters*/
call codes_get(igrib, "values", values1)
! setting decimal precision=2 means that 2 decimal digits
! are preserved when packing.
decimalPrecision=2
call codes_set(igrib,"setDecimalPrecision", &
decimalPrecision)
! setting decimal precision=2 means that 2 decimal digits
! are preserved when packing.
decimalPrecision = 2
call codes_set(igrib, "setDecimalPrecision", &
decimalPrecision)
! bitsPerValue after changing the packing parameters
call codes_get(igrib,"bitsPerValue",bitsPerValue2)
! bitsPerValue after changing the packing parameters
call codes_get(igrib, "bitsPerValue", bitsPerValue2)
! get data values after changing the packing parameters
call codes_get(igrib,"values",values2)
! get data values after changing the packing parameters
call codes_get(igrib, "values", values2)
! computing error
maxa=0
maxr=0
maxv=values2(1)
minv=maxv
do i=1,size
a=abs(values2(i)-values1(i))
if ( values2(i) .gt. maxv ) maxv=values2(i)
if ( values2(i) .lt. maxv ) minv=values2(i)
if ( values2(i) .ne. 0 ) then
r=abs((values2(i)-values1(i))/values2(i))
endif
if ( a .gt. maxa ) maxa=a
if ( r .gt. maxr ) maxr=r
enddo
write(*,*) "max absolute error = ",maxa
write(*,*) "max relative error = ",maxr
write(*,*) "min value = ",minv
write(*,*) "max value = ",maxv
! computing error
maxa = 0
maxr = 0
maxv = values2(1)
minv = maxv
do i = 1, size
a = abs(values2(i) - values1(i))
if (values2(i) .gt. maxv) maxv = values2(i)
if (values2(i) .lt. maxv) minv = values2(i)
if (values2(i) .ne. 0) then
r = abs((values2(i) - values1(i))/values2(i))
end if
if (a .gt. maxa) maxa = a
if (r .gt. maxr) maxr = r
end do
write (*, *) "max absolute error = ", maxa
write (*, *) "max relative error = ", maxr
write (*, *) "min value = ", minv
write (*, *) "max value = ", maxv
write(*,*) "old number of bits per value=",bitsPerValue1
write(*,*) "new number of bits per value=",bitsPerValue2
write (*, *) "old number of bits per value=", bitsPerValue1
write (*, *) "new number of bits per value=", bitsPerValue2
! write modified message to a file
call codes_write(igrib,outfile)
! write modified message to a file
call codes_write(igrib, outfile)
call codes_release(igrib)
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(infile)
call codes_close_file(outfile)
call codes_close_file(outfile)
deallocate(values1)
deallocate(values2)
deallocate (values1)
deallocate (values2)
end program precision

56
examples/F90/print_data_fortran.f90
View File

@ -13,41 +13,41 @@
!
!
program print_data_fortran
use eccodes
implicit none
integer :: ifile
integer :: igrib
integer :: i
real(kind=8), dimension(:), allocatable :: values
real(kind=8) :: average
real(kind=8) :: max
real(kind=8) :: min
use eccodes
implicit none
integer :: ifile
integer :: igrib
integer :: i
real(kind=8), dimension(:), allocatable :: values
real(kind=8) :: average
real(kind=8) :: max
real(kind=8) :: min
call codes_open_file(ifile, &
'../../data/constant_field.grib1','r')
call codes_open_file(ifile, &
'../../data/constant_field.grib1', 'r')
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(ifile,igrib)
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(ifile, igrib)
call codes_get(igrib,'values',values)
call codes_get(igrib, 'values', values)
do i=1,size(values)
write(*,*)' ',i,values(i)
enddo
do i = 1, size(values)
write (*, *) ' ', i, values(i)
end do
write(*,*)size(values),' values found '
write (*, *) size(values), ' values found '
call codes_get(igrib,'max',max)
write(*,*) 'max=',max
call codes_get(igrib,'min',min)
write(*,*) 'min=',min
call codes_get(igrib,'average',average)
write(*,*) 'average=',average
call codes_get(igrib, 'max', max)
write (*, *) 'max=', max
call codes_get(igrib, 'min', min)
write (*, *) 'min=', min
call codes_get(igrib, 'average', average)
write (*, *) 'average=', average
call codes_release(igrib)
call codes_release(igrib)
call codes_close_file(ifile)
call codes_close_file(ifile)
deallocate(values)
deallocate (values)
end program print_data_fortran

132
examples/F90/read_from_file.f90
View File

@ -10,88 +10,88 @@
! See GRIB-292
!
program read_from_file
use eccodes
implicit none
character(len=32) :: input_grib_file
integer,dimension(26) :: message_lengths ! expected message lengths
use eccodes
implicit none
character(len=32) :: input_grib_file
integer, dimension(26) :: message_lengths ! expected message lengths
input_grib_file = '../../data/v.grib2'
message_lengths = (/ 95917, 96963, 97308, 97386, 97215, 97440, 98451, 98629, 98448, &
99186, 97517, 97466, 99307, 98460,101491, 99361,100292, 96838, &
91093, 83247, 78244, 74872, 72663, 69305, 69881, 68572 /)
input_grib_file = '../../data/v.grib2'
message_lengths = (/95917, 96963, 97308, 97386, 97215, 97440, 98451, 98629, 98448, &
99186, 97517, 97466, 99307, 98460, 101491, 99361, 100292, 96838, &
91093, 83247, 78244, 74872, 72663, 69305, 69881, 68572/)
! Get the grib message length using two different interfaces
call read_using_size_t()
call read_using_integer()
print *,'Passed'
! Get the grib message length using two different interfaces
call read_using_size_t()
call read_using_integer()
print *, 'Passed'
contains
!======================================
subroutine read_using_size_t
implicit none
integer :: size,intsize
parameter (intsize=100000,size=intsize*4)
integer :: ifile
integer :: iret
integer :: count1=0
integer(kind=4),dimension(intsize) :: buffer
integer(kind=kindOfSize_t) :: len1 ! For large messages
subroutine read_using_size_t
implicit none
integer :: size, intsize
parameter(intsize=100000, size=intsize*4)
integer :: ifile
integer :: iret
integer :: count1 = 0
integer(kind=4), dimension(intsize) :: buffer
integer(kind=kindOfSize_t) :: len1 ! For large messages
ifile=5
call codes_open_file(ifile, input_grib_file, 'r')
ifile = 5
call codes_open_file(ifile, input_grib_file, 'r')
len1=size
call codes_read_from_file(ifile, buffer, len1, iret)
len1 = size
call codes_read_from_file(ifile, buffer, len1, iret)
do while (iret==CODES_SUCCESS)
count1=count1+1
if (len1 /= message_lengths(count1)) then
write(*,'(a,i3,a,i8,a,i8)') 'Error: Message #',count1,' length=', len1,'. Expected=',message_lengths(count1)
stop
end if
len1=size
call codes_read_from_file(ifile, buffer, len1, iret)
end do
do while (iret == CODES_SUCCESS)
count1 = count1 + 1
if (len1 /= message_lengths(count1)) then
write (*, '(a,i3,a,i8,a,i8)') 'Error: Message #', count1, ' length=', len1, '. Expected=', message_lengths(count1)
stop
end if
len1 = size
call codes_read_from_file(ifile, buffer, len1, iret)
end do
if (iret/=CODES_END_OF_FILE) then
call codes_check(iret,'read_from_file','')
endif
call codes_close_file(ifile)
if (iret /= CODES_END_OF_FILE) then
call codes_check(iret, 'read_from_file', '')
end if
call codes_close_file(ifile)
end subroutine read_using_size_t
end subroutine read_using_size_t
!======================================
subroutine read_using_integer
implicit none
integer :: size,intsize
parameter (intsize=100000,size=intsize*4)
integer :: ifile
integer :: iret
integer :: count1=0
integer(kind=4),dimension(intsize) :: buffer
integer :: len1
subroutine read_using_integer
implicit none
integer :: size, intsize
parameter(intsize=100000, size=intsize*4)
integer :: ifile
integer :: iret
integer :: count1 = 0
integer(kind=4), dimension(intsize) :: buffer
integer :: len1
ifile=5
call codes_open_file(ifile, input_grib_file, 'r')
ifile = 5
call codes_open_file(ifile, input_grib_file, 'r')
len1=size
call codes_read_from_file(ifile, buffer, len1, iret)
len1 = size
call codes_read_from_file(ifile, buffer, len1, iret)
do while (iret==CODES_SUCCESS)
count1=count1+1
if (len1 /= message_lengths(count1)) then
write(*,'(a,i3,a,i8,a,i8)') 'Error: Message #',count1,' length=', len1,'. Expected=',message_lengths(count1)
stop
end if
len1=size
call codes_read_from_file(ifile, buffer, len1, iret)
end do
do while (iret == CODES_SUCCESS)
count1 = count1 + 1
if (len1 /= message_lengths(count1)) then
write (*, '(a,i3,a,i8,a,i8)') 'Error: Message #', count1, ' length=', len1, '. Expected=', message_lengths(count1)
stop
end if
len1 = size
call codes_read_from_file(ifile, buffer, len1, iret)
end do
if (iret/=CODES_END_OF_FILE) then
call codes_check(iret,'read_from_file','')
endif
call codes_close_file(ifile)
if (iret /= CODES_END_OF_FILE) then
call codes_check(iret, 'read_from_file', '')
end if
call codes_close_file(ifile)
end subroutine read_using_integer
end subroutine read_using_integer
!======================================
end program

64
examples/F90/set_fortran.f90
View File

@ -10,49 +10,49 @@
!
!
program set
use eccodes
implicit none
use eccodes
implicit none
integer(kind = 4) :: centre
integer(kind = 4) :: int_value
character(len = 10) :: string_value
character(len = 20) :: string_centre
integer :: infile,outfile
integer :: igrib
integer(kind=4) :: centre
integer(kind=4) :: int_value
character(len=10) :: string_value
character(len=20) :: string_centre
integer :: infile, outfile
integer :: igrib
infile=5
outfile=6
infile = 5
outfile = 6
call codes_open_file(infile, &
'../../data/regular_latlon_surface_constant.grib1','r')
call codes_open_file(infile, &
'../../data/regular_latlon_surface_constant.grib1', 'r')
call codes_open_file(outfile, &
'../../data/out.grib1','w')
call codes_open_file(outfile, &
'../../data/out.grib1', 'w')
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib)
! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib)
! set centre as a long */
centre=80
call codes_set(igrib,'centre',centre)
! set centre as a long */
centre = 80
call codes_set(igrib, 'centre', centre)
! get centre as a integer*4
call codes_get(igrib,'centre',int_value)
write(*,*) 'centre=',int_value
! get centre as a integer*4
call codes_get(igrib, 'centre', int_value)
write (*, *) 'centre=', int_value
! get centre as a string
call codes_get(igrib,'centre',string_value)
string_centre='centre='//string_value
write(*,*) string_centre
! get centre as a string
call codes_get(igrib, 'centre', string_value)
string_centre = 'centre='//string_value
write (*, *) string_centre
! write modified message to a file
call codes_write(igrib,outfile)
! write modified message to a file
call codes_write(igrib, outfile)
call codes_release(igrib)
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(infile)
call codes_close_file(outfile)
call codes_close_file(outfile)
end program set

40
examples/F90/set_missing_fortran.f90
View File

@ -10,34 +10,34 @@
!
!
program set
use eccodes
implicit none
integer :: infile,outfile
integer :: igrib
use eccodes
implicit none
integer :: infile, outfile
integer :: igrib
infile=5
outfile=6
infile = 5
outfile = 6
call codes_open_file(infile, &
'../../data/reduced_gaussian_pressure_level.grib2','r')
call codes_open_file(infile, &
'../../data/reduced_gaussian_pressure_level.grib2', 'r')
call codes_open_file(outfile, &
'out_surface_level.grib2','w')
call codes_open_file(outfile, &
'out_surface_level.grib2', 'w')
! a new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib)
! a new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile, igrib)
call codes_set(igrib,'typeOfFirstFixedSurface','sfc')
call codes_set_missing(igrib,'scaleFactorOfFirstFixedSurface')
call codes_set_missing(igrib,'scaledValueOfFirstFixedSurface')
call codes_set(igrib, 'typeOfFirstFixedSurface', 'sfc')
call codes_set_missing(igrib, 'scaleFactorOfFirstFixedSurface')
call codes_set_missing(igrib, 'scaledValueOfFirstFixedSurface')
call codes_write(igrib,outfile)
call codes_write(igrib, outfile)
call codes_release(igrib)
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(infile)
call codes_close_file(outfile)
call codes_close_file(outfile)
end program set

107
examples/python/grib_iterator.c
View File

@ -11,78 +11,85 @@
/*
* C Implementation: grib_iterator
*
* Description: how to use an iterator on lat/lon/values.
* Description: how to use an iterator on lat/lon/values for GRIB messages
*
*/
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "grib_api.h"
static void usage(const char* prog) {
printf("Usage: %s grib_file\n",prog);
exit(1);
static void usage(const char* prog)
{
printf("Usage: %s grib_file\n", prog);
exit(1);
}
int main(int argc, char** argv) {
FILE* in = NULL;
int err = 0;
double lat,lon,value;
int main(int argc, char** argv)
{
FILE* in = NULL;
int err = 0;
double lat, lon, value;
double missingValue = 1e+20; /* A value out of range */
int n=0;
char* filename = NULL;
int n = 0;
long bitmapPresent = 0;
char* filename = NULL;
/* Message handle. Required in all the grib_api calls acting on a message.*/
grib_handle *h = NULL;
/* Iterator on lat/lon/values.*/
grib_iterator* iter=NULL;
/* Message handle. Required in all the ecCodes calls acting on a message.*/
grib_handle* h = NULL;
/* Iterator on lat/lon/values.*/
grib_iterator* iter = NULL;
if (argc != 2) usage(argv[0]);
if (argc != 2) usage(argv[0]);
filename=strdup(argv[1]);
filename = argv[1];
in = fopen(filename,"rb");
if(!in) {
printf("ERROR: unable to open file %s\n",filename);
return 1;
}
in = fopen(filename, "rb");
if (!in) {
fprintf(stderr, "Error: unable to open file %s\n", filename);
return 1;
}
/* Loop on all the messages in a file.*/
while ((h = grib_handle_new_from_file(0,in,&err)) != NULL ) {
/* Check of errors after reading a message. */
if (err != GRIB_SUCCESS) GRIB_CHECK(err,0);
/* Loop on all the messages in a file.*/
while ((h = grib_handle_new_from_file(0, in, &err)) != NULL) {
/* Check of errors after reading a message. */
if (err != GRIB_SUCCESS) GRIB_CHECK(err, 0);
/* Set the double representing the missing value in the field. */
/* Choose a missingValue that does not correspond to any real value in the data array */
GRIB_CHECK(grib_set_double(h, "missingValue", missingValue),0);
/* Check if a bitmap applies */
GRIB_CHECK(grib_get_long(h, "bitmapPresent", &bitmapPresent), 0);
/* A new iterator on lat/lon/values is created from the message handle h. */
iter=grib_iterator_new(h,0,&err);
if (err != GRIB_SUCCESS) GRIB_CHECK(err,0);
if (bitmapPresent) {
/* Set the double representing the missing value in the field. */
/* Choose a missingValue that does not correspond to any real value in the data array */
GRIB_CHECK(grib_set_double(h, "missingValue", missingValue), 0);
}
n = 0;
/* Loop on all the lat/lon/values. */
while(grib_iterator_next(iter,&lat,&lon,&value)) {
/* You can now print lat and lon, */
printf("- %d - lat=%.6e lon=%.6e value=",n,lat,lon);
/* decide what to print if a missing value is found. */
if (value == missingValue ) printf("missing\n");
/* and print the value if is not missing. */
else printf("%f\n",value);
n++;
}
/* A new iterator on lat/lon/values is created from the message handle h. */
iter = grib_iterator_new(h, 0, &err);
if (err != GRIB_SUCCESS) GRIB_CHECK(err, 0);
/* At the end the iterator is deleted to free memory. */
grib_iterator_delete(iter);
n = 0;
/* Loop on all the lat/lon/values. */
while (grib_iterator_next(iter, &lat, &lon, &value)) {
/* You can now print lat and lon, */
printf("- %d - lat=%.6e lon=%.6e value=", n, lat, lon);
/* decide what to print if a missing value is found. */
if (bitmapPresent && value == missingValue) printf("missing\n");
/* and print the value if is not missing. */
else
printf("%f\n", value);
n++;
}
/* At the end the grib_handle is deleted to free memory. */
grib_handle_delete(h);
}
/* At the end the iterator is deleted to free memory. */
grib_iterator_delete(iter);
/* At the end the grib_handle is deleted to free memory. */
grib_handle_delete(h);
}
fclose(in);
fclose(in);
return 0;
return 0;
}

13
examples/python/grib_iterator.py
View File

@ -19,16 +19,19 @@ missingValue = 1e+20 # A value out of range
def example(INPUT):
f = open(INPUT, 'rb')
f = open(INPUT, "rb")
while 1:
gid = codes_grib_new_from_file(f)
if gid is None:
break
# Set the value representing the missing value in the field.
# Choose a missingValue that does not correspond to any real value in the data array
codes_set(gid, "missingValue", missingValue)
bitmapPresent = codes_get(gid, "bitmapPresent")
if bitmapPresent:
# Set the value representing the missing value in the field.
# Choose a missingValue that does not correspond to any real value in the data array
codes_set(gid, "missingValue", missingValue)
iterid = codes_grib_iterator_new(gid, 0)
@ -42,7 +45,7 @@ def example(INPUT):
sys.stdout.write("- %d - lat=%.6e lon=%.6e value=" % (i, lat, lon))
if value == missingValue:
if bitmapPresent and value == missingValue:
print("missing")
else:
print("%.6f" % value)

27
fortran/eccodes_f90_head.f90
View File

@ -17,13 +17,12 @@ module eccodes
include "eccodes_visibility.h"
include "eccodes_settings.h"
real(8), parameter,public :: CODES_MISSING_DOUBLE = -1.D+100
integer(4), parameter,public :: CODES_MISSING_LONG = 2147483647
integer, parameter,public :: CODES_PRODUCT_ANY = 0
integer, parameter,public :: CODES_PRODUCT_GRIB = 1
integer, parameter,public :: CODES_PRODUCT_BUFR = 2
real(8), parameter, public :: CODES_MISSING_DOUBLE = -1.D+100
integer(4), parameter, public :: CODES_MISSING_LONG = 2147483647
integer, parameter, public :: CODES_PRODUCT_ANY = 0
integer, parameter, public :: CODES_PRODUCT_GRIB = 1
integer, parameter, public :: CODES_PRODUCT_BUFR = 2
!> Create a new message in memory from an integer or character array containting the coded message.
!>
@ -42,8 +41,8 @@ module eccodes
!> @param message array containing the coded message
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_new_from_message
module procedure codes_new_from_message_int4
module procedure codes_new_from_message_char
module procedure codes_new_from_message_int4
module procedure codes_new_from_message_char
end interface codes_new_from_message
!> Get a value of specified index from an array key.
@ -70,9 +69,9 @@ module eccodes
!> @param[out] status CODES_SUCCESS if OK, integer value on error
interface codes_get_element
module procedure codes_get_real4_element, &
codes_get_real8_element, &
codes_get_real4_elements, &
codes_get_real8_elements
codes_get_real8_element, &
codes_get_real4_elements, &
codes_get_real8_elements
end interface codes_get_element
!> Find the nearest point/points of a given latitude/longitude point.
@ -113,8 +112,8 @@ module eccodes
!> @param[out] status CODES_SUCCESS if OK, integer value on error
interface codes_grib_find_nearest
module procedure codes_grib_find_nearest_single, &
codes_grib_find_nearest_four_single, &
codes_grib_find_nearest_multiple
codes_grib_find_nearest_four_single, &
codes_grib_find_nearest_multiple
end interface codes_grib_find_nearest
!> Get latitude/longitude and data values.
@ -136,5 +135,5 @@ module eccodes
!> @param[out] values data values array with dimension "size"
interface codes_grib_get_data
module procedure codes_grib_get_data_real4, &
codes_grib_get_data_real8
codes_grib_get_data_real8
end interface codes_grib_get_data

44
fortran/eccodes_f90_int.f90
View File

@ -6,7 +6,6 @@
! In applying this licence, ECMWF does not waive the privileges and immunities granted to it by
! virtue of its status as an intergovernmental organisation nor does it submit to any jurisdiction.
!> Get the distinct values of the key in argument contained in the index. The key must belong to the index.
!>
!>
@ -22,8 +21,8 @@
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_index_get
module procedure codes_index_get_int, &
codes_index_get_string, &
codes_index_get_real8
codes_index_get_string, &
codes_index_get_real8
end interface codes_index_get
!> Get the number of distinct values of the key in argument contained in the index. The key must belong to the index.
@ -40,7 +39,7 @@
!> @param size number of distinct values of the key in the index
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_index_get_size
module procedure codes_index_get_size_int
module procedure codes_index_get_size_int
end interface codes_index_get_size
!> Select the message subset with key==value.
@ -58,8 +57,8 @@
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_index_select
module procedure codes_index_select_int, &
codes_index_select_string, &
codes_index_select_real8
codes_index_select_string, &
codes_index_select_real8
end interface codes_index_select
!> Get the value for a key from a message.
@ -96,16 +95,15 @@
!> @param[out] status CODES_SUCCESS if OK, integer value on error
interface codes_get
module procedure codes_get_int, &
codes_get_real4, &
codes_get_real8, &
codes_get_string, &
codes_get_byte_array, &
codes_get_int_array, &
codes_get_real4_array, &
codes_get_real8_array
codes_get_real4, &
codes_get_real8, &
codes_get_string, &
codes_get_byte_array, &
codes_get_int_array, &
codes_get_real4_array, &
codes_get_real8_array
end interface codes_get
!> Get the size of an array key.
!>
!> To get the size of a key representing an array.
@ -119,7 +117,7 @@
!> @param size size of the array key
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_get_size
module procedure codes_get_size_int
module procedure codes_get_size_int
end interface codes_get_size
!> Set the value for a key in a message.
@ -147,17 +145,17 @@
!> @param[out] status CODES_SUCCESS if OK, integer value on error
interface codes_set
module procedure codes_set_int, &
codes_set_real4, &
codes_set_real8, &
codes_set_string, &
codes_set_int_array, &
codes_set_byte_array, &
codes_set_real4_array, &
codes_set_real8_array
codes_set_real4, &
codes_set_real8, &
codes_set_string, &
codes_set_int_array, &
codes_set_byte_array, &
codes_set_real4_array, &
codes_set_real8_array
end interface codes_set
interface codes_set_force
module procedure codes_set_force_real4_array, &
codes_set_force_real8_array
codes_set_force_real8_array
end interface codes_set_force

20
fortran/eccodes_f90_int_size_t.f90
View File

@ -17,8 +17,8 @@
!> @param nbytes number of bytes to be read
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_read_from_file
module procedure codes_read_from_file_int4
module procedure codes_read_from_file_char
module procedure codes_read_from_file_int4
module procedure codes_read_from_file_char
end interface codes_read_from_file
!> Reads nbytes bytes into the buffer from a file opened with codes_open_file.
@ -32,10 +32,10 @@
!> @param nbytes number of bytes to be read
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_read_bytes
module procedure codes_read_bytes_int4
module procedure codes_read_bytes_char
module procedure codes_read_bytes_real8
module procedure codes_read_bytes_real4
module procedure codes_read_bytes_int4
module procedure codes_read_bytes_char
module procedure codes_read_bytes_real8
module procedure codes_read_bytes_real4
end interface codes_read_bytes
!> Write nbytes bytes from the buffer in a file opened with codes_open_file.
@ -49,10 +49,10 @@
!> @param nbytes number of bytes to be written
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_write_bytes
module procedure codes_write_bytes_int4
module procedure codes_write_bytes_char
module procedure codes_write_bytes_real8
module procedure codes_write_bytes_real4
module procedure codes_write_bytes_int4
module procedure codes_write_bytes_char
module procedure codes_write_bytes_real8
module procedure codes_write_bytes_real4
end interface codes_write_bytes
!> Get the size of a coded message.

55
fortran/eccodes_f90_long_int.f90
View File

@ -6,7 +6,6 @@
! In applying this licence, ECMWF does not waive the privileges and immunities granted to it by
! virtue of its status as an intergovernmental organisation nor does it submit to any jurisdiction.
!> Get the distinct values of the key in argument contained in the index. The key must belong to the index.
!>
!>
@ -22,9 +21,9 @@
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_index_get
module procedure codes_index_get_int, &
codes_index_get_long, &
codes_index_get_string, &
codes_index_get_real8
codes_index_get_long, &
codes_index_get_string, &
codes_index_get_real8
end interface codes_index_get
!> Get the number of distinct values of the key in argument contained in the index. The key must belong to the index.
@ -41,7 +40,7 @@
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_index_get_size
module procedure codes_index_get_size_int, &
codes_index_get_size_long
codes_index_get_size_long
end interface codes_index_get_size
!> Select the message subset with key==value.
@ -59,9 +58,9 @@
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_index_select
module procedure codes_index_select_int, &
codes_index_select_long, &
codes_index_select_string, &
codes_index_select_real8
codes_index_select_long, &
codes_index_select_string, &
codes_index_select_real8
end interface codes_index_select
!> Get the value for a key from a message.
@ -96,14 +95,14 @@
!> @param[out] status CODES_SUCCESS if OK, integer value on error
interface codes_get
module procedure codes_get_int, &
codes_get_long, &
codes_get_real4, &
codes_get_real8, &
codes_get_string, &
codes_get_byte_array, &
codes_get_int_array, &
codes_get_real4_array, &
codes_get_real8_array
codes_get_long, &
codes_get_real4, &
codes_get_real8, &
codes_get_string, &
codes_get_byte_array, &
codes_get_int_array, &
codes_get_real4_array, &
codes_get_real8_array
end interface codes_get
!> Get the size of an array key.
@ -119,8 +118,8 @@
!> @param size size of the array key
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_get_size
module procedure codes_get_size_int, &
codes_get_size_long
module procedure codes_get_size_int, &
codes_get_size_long
end interface codes_get_size
!> Set the value for a key in a message.
@ -148,19 +147,19 @@
!> @param[out] status CODES_SUCCESS if OK, integer value on error
interface codes_set
module procedure codes_set_int, &
codes_set_long, &
codes_set_real4, &
codes_set_real8, &
codes_set_string, &
codes_set_int_array, &
codes_set_long_array, &
codes_set_byte_array, &
codes_set_real4_array, &
codes_set_real8_array
codes_set_long, &
codes_set_real4, &
codes_set_real8, &
codes_set_string, &
codes_set_int_array, &
codes_set_long_array, &
codes_set_byte_array, &
codes_set_real4_array, &
codes_set_real8_array
end interface codes_set
interface codes_set_force
module procedure codes_set_force_real4_array, &
codes_set_force_real8_array
codes_set_force_real8_array
end interface codes_set_force

40
fortran/eccodes_f90_long_size_t.f90
View File

@ -17,10 +17,10 @@
!> @param nbytes number of bytes to be read
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_read_from_file
module procedure codes_read_from_file_int4
module procedure codes_read_from_file_int4_size_t
module procedure codes_read_from_file_char
module procedure codes_read_from_file_char_size_t
module procedure codes_read_from_file_int4
module procedure codes_read_from_file_int4_size_t
module procedure codes_read_from_file_char
module procedure codes_read_from_file_char_size_t
end interface codes_read_from_file
!> Reads nbytes bytes into the buffer from a file opened with codes_open_file.
@ -34,14 +34,14 @@
!> @param nbytes number of bytes to be read
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_read_bytes
module procedure codes_read_bytes_int4
module procedure codes_read_bytes_int4_size_t
module procedure codes_read_bytes_char
module procedure codes_read_bytes_char_size_t
module procedure codes_read_bytes_real8
module procedure codes_read_bytes_real8_size_t
module procedure codes_read_bytes_real4
module procedure codes_read_bytes_real4_size_t
module procedure codes_read_bytes_int4
module procedure codes_read_bytes_int4_size_t
module procedure codes_read_bytes_char
module procedure codes_read_bytes_char_size_t
module procedure codes_read_bytes_real8
module procedure codes_read_bytes_real8_size_t
module procedure codes_read_bytes_real4
module procedure codes_read_bytes_real4_size_t
end interface codes_read_bytes
!> Write nbytes bytes from the buffer in a file opened with codes_open_file.
@ -55,14 +55,14 @@
!> @param nbytes number of bytes to be written
!> @param status CODES_SUCCESS if OK, integer value on error
interface codes_write_bytes
module procedure codes_write_bytes_int4
module procedure codes_write_bytes_int4_size_t
module procedure codes_write_bytes_char
module procedure codes_write_bytes_char_size_t
module procedure codes_write_bytes_real8
module procedure codes_write_bytes_real8_size_t
module procedure codes_write_bytes_real4
module procedure codes_write_bytes_real4_size_t
module procedure codes_write_bytes_int4
module procedure codes_write_bytes_int4_size_t
module procedure codes_write_bytes_char
module procedure codes_write_bytes_char_size_t
module procedure codes_write_bytes_real8
module procedure codes_write_bytes_real8_size_t
module procedure codes_write_bytes_real4
module procedure codes_write_bytes_real4_size_t
end interface codes_write_bytes
!> Get the size of a coded message.

1970
fortran/eccodes_f90_tail.f90
View File

File diff suppressed because it is too large Load Diff

152
fortran/fortranCtypes/test.f90
View File

@ -4,25 +4,25 @@ integer function kind_of_long_long
integer(8), dimension(2) :: x8 = (/1, 2/)
character(len=1) :: ret
kind_of_long_long=-1
kind_of_long_long = -1
call check_long_long(x2(0),x2(1),ret)
call check_long_long(x2(0), x2(1), ret)
if (ret == 't') then
kind_of_long_long=2
return
endif
kind_of_long_long = 2
return
end if
call check_long_long(x4(0),x4(1),ret)
call check_long_long(x4(0), x4(1), ret)
if (ret == 't') then
kind_of_long_long=4
return
endif
kind_of_long_long = 4
return
end if
call check_long_long(x8(0),x8(1),ret)
call check_long_long(x8(0), x8(1), ret)
if (ret == 't') then
kind_of_long_long=8
return
endif
kind_of_long_long = 8
return
end if
end function kind_of_long_long
@ -32,25 +32,25 @@ integer function kind_of_size_t
integer(8), dimension(2) :: x8 = (/1, 2/)
character(len=1) :: ret
kind_of_size_t=-1
kind_of_size_t = -1
call check_size_t(x2(0),x2(1),ret)
call check_size_t(x2(0), x2(1), ret)
if (ret == 't') then
kind_of_size_t=2
return
endif
kind_of_size_t = 2
return
end if
call check_size_t(x4(0),x4(1),ret)
call check_size_t(x4(0), x4(1), ret)
if (ret == 't') then
kind_of_size_t=4
return
endif
kind_of_size_t = 4
return
end if
call check_size_t(x8(0),x8(1),ret)
call check_size_t(x8(0), x8(1), ret)
if (ret == 't') then
kind_of_size_t=8
return
endif
kind_of_size_t = 8
return
end if
end function kind_of_size_t
@ -60,25 +60,25 @@ integer function kind_of_long
integer(8), dimension(2) :: x8 = (/1, 2/)
character(len=1) :: ret
kind_of_long=-1
kind_of_long = -1
call check_long(x2(0),x2(1),ret)
call check_long(x2(0), x2(1), ret)
if (ret == 't') then
kind_of_long=2
return
endif
kind_of_long = 2
return
end if
call check_long(x4(0),x4(1),ret)
call check_long(x4(0), x4(1), ret)
if (ret == 't') then
kind_of_long=4
return
endif
kind_of_long = 4
return
end if
call check_long(x8(0),x8(1),ret)
call check_long(x8(0), x8(1), ret)
if (ret == 't') then
kind_of_long=8
return
endif
kind_of_long = 8
return
end if
end function kind_of_long
@ -88,25 +88,25 @@ integer function kind_of_int
integer(8), dimension(2) :: x8 = (/1, 2/)
character(len=1) :: ret
kind_of_int=-1
kind_of_int = -1
call check_int(x2(0),x2(1),ret)
call check_int(x2(0), x2(1), ret)
if (ret == 't') then
kind_of_int=2
return
endif
kind_of_int = 2
return
end if
call check_int(x4(0),x4(1),ret)
call check_int(x4(0), x4(1), ret)
if (ret == 't') then
kind_of_int=4
return
endif
kind_of_int = 4
return
end if
call check_int(x8(0),x8(1),ret)
call check_int(x8(0), x8(1), ret)
if (ret == 't') then
kind_of_int=8
return
endif
kind_of_int = 8
return
end if
end function kind_of_int
@ -115,19 +115,19 @@ integer function kind_of_float
real(8), dimension(2) :: x8 = (/1., 2./)
character(len=1) :: ret
kind_of_float=-1
kind_of_float = -1
call check_float(x4(0),x4(1),ret)
call check_float(x4(0), x4(1), ret)
if (ret == 't') then
kind_of_float=4
return
endif
kind_of_float = 4
return
end if
call check_float(x8(0),x8(1),ret)
call check_float(x8(0), x8(1), ret)
if (ret == 't') then
kind_of_float=8
return
endif
kind_of_float = 8
return
end if
end function kind_of_float
@ -136,30 +136,30 @@ integer function kind_of_double
real(8), dimension(2) :: real8 = (/1., 2./)
character(len=1) :: ret
kind_of_double=-1
kind_of_double = -1
call check_double(real4(0),real4(1),ret)
call check_double(real4(0), real4(1), ret)
if (ret == 't') then
kind_of_double=4
return
endif
kind_of_double = 4
return
end if
call check_double(real8(0),real8(1),ret)
call check_double(real8(0), real8(1), ret)
if (ret == 't') then
kind_of_double=8
return
endif
kind_of_double = 8
return
end if
end function kind_of_double
program test
print *,'kind_of_double=',kind_of_double()
print *,'kind_of_float=',kind_of_float()
print *,'kind_of_int=',kind_of_int()
print *,'kind_of_long=',kind_of_long()
print *,'kind_of_size_t=',kind_of_size_t()
print *,'kind_of_long_long=',kind_of_long_long()
print *, 'kind_of_double=', kind_of_double()
print *, 'kind_of_float=', kind_of_float()
print *, 'kind_of_int=', kind_of_int()
print *, 'kind_of_long=', kind_of_long()
print *, 'kind_of_size_t=', kind_of_size_t()
print *, 'kind_of_long_long=', kind_of_long_long()
end program test

21
fortran/grib_f90_head.f90
View File

@ -18,9 +18,8 @@ module grib_api
include "grib_api_externals.h"
include "grib_api_visibility.h"
real(8), parameter,public :: GRIB_MISSING_DOUBLE = -1.D+100
integer(4), parameter,public :: GRIB_MISSING_LONG = 2147483647
real(8), parameter, public :: GRIB_MISSING_DOUBLE = -1.D+100
integer(4), parameter, public :: GRIB_MISSING_LONG = 2147483647
!> Create a new message in memory from an integer or character array containting the coded message.
!>
@ -39,8 +38,8 @@ module grib_api
!> @param message array containing the coded message
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_new_from_message
module procedure grib_new_from_message_int4
module procedure grib_new_from_message_char
module procedure grib_new_from_message_int4
module procedure grib_new_from_message_char
end interface grib_new_from_message
!> Get a value of specified index from an array key.
@ -67,9 +66,9 @@ module grib_api
!> @param[out] status GRIB_SUCCESS if OK, integer value on error
interface grib_get_element
module procedure grib_get_real4_element, &
grib_get_real8_element, &
grib_get_real4_elements, &
grib_get_real8_elements
grib_get_real8_element, &
grib_get_real4_elements, &
grib_get_real8_elements
end interface grib_get_element
!> Find the nearest point/points of a given latitude/longitude point.
@ -110,8 +109,8 @@ module grib_api
!> @param[out] status GRIB_SUCCESS if OK, integer value on error
interface grib_find_nearest
module procedure grib_find_nearest_single, &
grib_find_nearest_four_single, &
grib_find_nearest_multiple
grib_find_nearest_four_single, &
grib_find_nearest_multiple
end interface grib_find_nearest
!> Get latitude/longitude and data values.
@ -134,6 +133,6 @@ module grib_api
!> @param[out] status GRIB_SUCCESS if OK, integer value on error
interface grib_get_data
module procedure grib_get_data_real4, &
grib_get_data_real8
grib_get_data_real8
end interface grib_get_data

44
fortran/grib_f90_int.f90
View File

@ -6,7 +6,6 @@
! In applying this licence, ECMWF does not waive the privileges and immunities granted to it by
! virtue of its status as an intergovernmental organisation nor does it submit to any jurisdiction.
!> Get the distinct values of the key in argument contained in the index. The key must belong to the index.
!>
!>
@ -22,8 +21,8 @@
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_index_get
module procedure grib_index_get_int, &
grib_index_get_string, &
grib_index_get_real8
grib_index_get_string, &
grib_index_get_real8
end interface grib_index_get
!> Get the number of distinct values of the key in argument contained in the index. The key must belong to the index.
@ -40,7 +39,7 @@
!> @param size number of distinct values of the key in the index
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_index_get_size
module procedure grib_index_get_size_int
module procedure grib_index_get_size_int
end interface grib_index_get_size
!> Select the message subset with key==value.
@ -58,8 +57,8 @@
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_index_select
module procedure grib_index_select_int, &
grib_index_select_string, &
grib_index_select_real8
grib_index_select_string, &
grib_index_select_real8
end interface grib_index_select
!> Get the value for a key from a message.
@ -94,16 +93,15 @@
!> @param[out] status GRIB_SUCCESS if OK, integer value on error
interface grib_get
module procedure grib_get_int, &
grib_get_real4, &
grib_get_real8, &
grib_get_string, &
grib_get_int_array, &
grib_get_byte_array, &
grib_get_real4_array, &
grib_get_real8_array
grib_get_real4, &
grib_get_real8, &
grib_get_string, &
grib_get_int_array, &
grib_get_byte_array, &
grib_get_real4_array, &
grib_get_real8_array
end interface grib_get
!> Get the size of an array key.
!>
!> To get the size of a key representing an array.
@ -117,7 +115,7 @@
!> @param size size of the array key
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_get_size
module procedure grib_get_size_int
module procedure grib_get_size_int
end interface grib_get_size
!> Set the value for a key in a message.
@ -145,16 +143,16 @@
!> @param[out] status GRIB_SUCCESS if OK, integer value on error
interface grib_set
module procedure grib_set_int, &
grib_set_real4, &
grib_set_real8, &
grib_set_string, &
grib_set_int_array, &
grib_set_byte_array, &
grib_set_real4_array, &
grib_set_real8_array
grib_set_real4, &
grib_set_real8, &
grib_set_string, &
grib_set_int_array, &
grib_set_byte_array, &
grib_set_real4_array, &
grib_set_real8_array
end interface grib_set
interface grib_set_force
module procedure grib_set_force_real4_array, &
grib_set_force_real8_array
grib_set_force_real8_array
end interface grib_set_force

20
fortran/grib_f90_int_size_t.f90
View File

@ -18,8 +18,8 @@
!> @param nbytes number of bytes to be read
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_read_from_file
module procedure grib_read_from_file_int4
module procedure grib_read_from_file_char
module procedure grib_read_from_file_int4
module procedure grib_read_from_file_char
end interface grib_read_from_file
!> Reads nbytes bytes into the buffer from a file opened with grib_open_file.
@ -34,10 +34,10 @@
!> @param nbytes number of bytes to be read
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_read_bytes
module procedure grib_read_bytes_int4
module procedure grib_read_bytes_char
module procedure grib_read_bytes_real8
module procedure grib_read_bytes_real4
module procedure grib_read_bytes_int4
module procedure grib_read_bytes_char
module procedure grib_read_bytes_real8
module procedure grib_read_bytes_real4
end interface grib_read_bytes
!> Write nbytes bytes from the buffer in a file opened with grib_open_file.
@ -52,10 +52,10 @@
!> @param nbytes number of bytes to be written
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_write_bytes
module procedure grib_write_bytes_int4
module procedure grib_write_bytes_char
module procedure grib_write_bytes_real8
module procedure grib_write_bytes_real4
module procedure grib_write_bytes_int4
module procedure grib_write_bytes_char
module procedure grib_write_bytes_real8
module procedure grib_write_bytes_real4
end interface grib_write_bytes
!> Get the size of a coded message.

55
fortran/grib_f90_long_int.f90
View File

@ -6,7 +6,6 @@
! In applying this licence, ECMWF does not waive the privileges and immunities granted to it by
! virtue of its status as an intergovernmental organisation nor does it submit to any jurisdiction.
!> Get the distinct values of the key in argument contained in the index. The key must belong to the index.
!>
!>
@ -22,9 +21,9 @@
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_index_get
module procedure grib_index_get_int, &
grib_index_get_long, &
grib_index_get_string, &
grib_index_get_real8
grib_index_get_long, &
grib_index_get_string, &
grib_index_get_real8
end interface grib_index_get
!> Get the number of distinct values of the key in argument contained in the index. The key must belong to the index.
@ -42,7 +41,7 @@
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_index_get_size
module procedure grib_index_get_size_int, &
grib_index_get_size_long
grib_index_get_size_long
end interface grib_index_get_size
!> Select the message subset with key==value.
@ -60,9 +59,9 @@
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_index_select
module procedure grib_index_select_int, &
grib_index_select_long, &
grib_index_select_string, &
grib_index_select_real8
grib_index_select_long, &
grib_index_select_string, &
grib_index_select_real8
end interface grib_index_select
!> Get the value for a key from a message.
@ -97,14 +96,14 @@
!> @param[out] status GRIB_SUCCESS if OK, integer value on error
interface grib_get
module procedure grib_get_int, &
grib_get_long, &
grib_get_real4, &
grib_get_real8, &
grib_get_string, &
grib_get_int_array, &
grib_get_byte_array, &
grib_get_real4_array, &
grib_get_real8_array
grib_get_long, &
grib_get_real4, &
grib_get_real8, &
grib_get_string, &
grib_get_int_array, &
grib_get_byte_array, &
grib_get_real4_array, &
grib_get_real8_array
end interface grib_get
!> Get the size of an array key.
@ -120,8 +119,8 @@
!> @param size size of the array key
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_get_size
module procedure grib_get_size_int, &
grib_get_size_long
module procedure grib_get_size_int, &
grib_get_size_long
end interface grib_get_size
!> Set the value for a key in a message.
@ -149,18 +148,18 @@
!> @param[out] status GRIB_SUCCESS if OK, integer value on error
interface grib_set
module procedure grib_set_int, &
grib_set_long, &
grib_set_real4, &
grib_set_real8, &
grib_set_string, &
grib_set_int_array, &
grib_set_long_array, &
grib_set_byte_array, &
grib_set_real4_array, &
grib_set_real8_array
grib_set_long, &
grib_set_real4, &
grib_set_real8, &
grib_set_string, &
grib_set_int_array, &
grib_set_long_array, &
grib_set_byte_array, &
grib_set_real4_array, &
grib_set_real8_array
end interface grib_set
interface grib_set_force
module procedure grib_set_force_real4_array, &
grib_set_force_real8_array
grib_set_force_real8_array
end interface grib_set_force

40
fortran/grib_f90_long_size_t.f90
View File

@ -18,10 +18,10 @@
!> @param nbytes number of bytes to be read
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_read_from_file
module procedure grib_read_from_file_int4
module procedure grib_read_from_file_int4_size_t
module procedure grib_read_from_file_char
module procedure grib_read_from_file_char_size_t
module procedure grib_read_from_file_int4
module procedure grib_read_from_file_int4_size_t
module procedure grib_read_from_file_char
module procedure grib_read_from_file_char_size_t
end interface grib_read_from_file
!> Reads nbytes bytes into the buffer from a file opened with grib_open_file.
@ -36,14 +36,14 @@
!> @param nbytes number of bytes to be read
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_read_bytes
module procedure grib_read_bytes_int4
module procedure grib_read_bytes_int4_size_t
module procedure grib_read_bytes_char
module procedure grib_read_bytes_char_size_t
module procedure grib_read_bytes_real8
module procedure grib_read_bytes_real8_size_t
module procedure grib_read_bytes_real4
module procedure grib_read_bytes_real4_size_t
module procedure grib_read_bytes_int4
module procedure grib_read_bytes_int4_size_t
module procedure grib_read_bytes_char
module procedure grib_read_bytes_char_size_t
module procedure grib_read_bytes_real8
module procedure grib_read_bytes_real8_size_t
module procedure grib_read_bytes_real4
module procedure grib_read_bytes_real4_size_t
end interface grib_read_bytes
!> Write nbytes bytes from the buffer in a file opened with grib_open_file.
@ -58,14 +58,14 @@
!> @param nbytes number of bytes to be written
!> @param status GRIB_SUCCESS if OK, integer value on error
interface grib_write_bytes
module procedure grib_write_bytes_int4
module procedure grib_write_bytes_int4_size_t
module procedure grib_write_bytes_char
module procedure grib_write_bytes_char_size_t
module procedure grib_write_bytes_real8
module procedure grib_write_bytes_real8_size_t
module procedure grib_write_bytes_real4
module procedure grib_write_bytes_real4_size_t
module procedure grib_write_bytes_int4
module procedure grib_write_bytes_int4_size_t
module procedure grib_write_bytes_char
module procedure grib_write_bytes_char_size_t
module procedure grib_write_bytes_real8
module procedure grib_write_bytes_real8_size_t
module procedure grib_write_bytes_real4
module procedure grib_write_bytes_real4_size_t
end interface grib_write_bytes
!> Get the size of a coded message.

2940
fortran/grib_f90_tail.f90
View File

File diff suppressed because it is too large Load Diff

20
fortran/grib_typeSizes.f90
View File

@ -33,21 +33,21 @@ module grib_typeSizes
integer, parameter :: FourByteInt = selected_int_kind(9), &
EightByteInt = selected_int_kind(18)
integer, parameter :: FourByteReal = selected_real_kind(P = 6, R = 37), &
EightByteReal = selected_real_kind(P = 13, R = 307)
integer, parameter :: FourByteReal = selected_real_kind(P=6, R=37), &
EightByteReal = selected_real_kind(P=13, R=307)
contains
logical function byteSizesOK()
! Users may call this function once to ensure that the kind parameters
! the module defines are available with the current compiler.
! We can't ensure that the two REAL kinds are actually four and
! eight bytes long, but we can ensure that they are distinct.
! Early Fortran 90 compilers would sometimes report incorrect results for
! the bit_size intrinsic, but I haven't seen this in a long time.
! Users may call this function once to ensure that the kind parameters
! the module defines are available with the current compiler.
! We can't ensure that the two REAL kinds are actually four and
! eight bytes long, but we can ensure that they are distinct.
! Early Fortran 90 compilers would sometimes report incorrect results for
! the bit_size intrinsic, but I haven't seen this in a long time.
! Local variables
integer (kind = FourByteInt) :: Four
integer(kind=FourByteInt) :: Four
if (bit_size(Four) == 32 .and. &
if (bit_size(Four) == 32 .and. &
FourByteReal > 0 .and. EightByteReal > 0 .and. &
FourByteReal /= EightByteReal) then
byteSizesOK = .true.

146
fortran/grib_types.f90
View File

@ -12,25 +12,25 @@ integer function kind_of_size_t()
integer(8), dimension(2) :: x8 = (/1, 2/)
character(len=1) :: ret
kind_of_size_t=-1
kind_of_size_t = -1
call check_size_t(x2(1),x2(2),ret)
call check_size_t(x2(1), x2(2), ret)
if (ret == 't') then
kind_of_size_t=2
return
endif
kind_of_size_t = 2
return
end if
call check_size_t(x4(1),x4(2),ret)
call check_size_t(x4(1), x4(2), ret)
if (ret == 't') then
kind_of_size_t=4
return
endif
kind_of_size_t = 4
return
end if
call check_size_t(x8(1),x8(2),ret)
call check_size_t(x8(1), x8(2), ret)
if (ret == 't') then
kind_of_size_t=8
return
endif
kind_of_size_t = 8
return
end if
end function kind_of_size_t
@ -40,25 +40,25 @@ integer function kind_of_long()
integer(8), dimension(2) :: x8 = (/1, 2/)
character(len=1) :: ret
kind_of_long=-1
kind_of_long = -1
call check_long(x2(1),x2(2),ret)
call check_long(x2(1), x2(2), ret)
if (ret == 't') then
kind_of_long=2
return
endif
kind_of_long = 2
return
end if
call check_long(x4(1),x4(2),ret)
call check_long(x4(1), x4(2), ret)
if (ret == 't') then
kind_of_long=4
return
endif
kind_of_long = 4
return
end if
call check_long(x8(1),x8(2),ret)
call check_long(x8(1), x8(2), ret)
if (ret == 't') then
kind_of_long=8
return
endif
kind_of_long = 8
return
end if
end function kind_of_long
@ -68,25 +68,25 @@ integer function kind_of_int()
integer(8), dimension(2) :: x8 = (/1, 2/)
character(len=1) :: ret
kind_of_int=-1
kind_of_int = -1
call check_int(x2(1),x2(2),ret)
call check_int(x2(1), x2(2), ret)
if (ret == 't') then
kind_of_int=2
return
endif
kind_of_int = 2
return
end if
call check_int(x4(1),x4(2),ret)
call check_int(x4(1), x4(2), ret)
if (ret == 't') then
kind_of_int=4
return
endif
kind_of_int = 4
return
end if
call check_int(x8(1),x8(2),ret)
call check_int(x8(1), x8(2), ret)
if (ret == 't') then
kind_of_int=8
return
endif
kind_of_int = 8
return
end if
end function kind_of_int
@ -95,19 +95,19 @@ integer function kind_of_float()
real(8), dimension(2) :: x8 = (/1., 2./)
character(len=1) :: ret
kind_of_float=-1
kind_of_float = -1
call check_float(x4(1),x4(2),ret)
call check_float(x4(1), x4(2), ret)
if (ret == 't') then
kind_of_float=4
return
endif
kind_of_float = 4
return
end if
call check_float(x8(1),x8(2),ret)
call check_float(x8(1), x8(2), ret)
if (ret == 't') then
kind_of_float=8
return
endif
kind_of_float = 8
return
end if
end function kind_of_float
@ -116,19 +116,19 @@ integer function kind_of_double()
real(8), dimension(2) :: real8 = (/1., 2./)
character(len=1) :: ret
kind_of_double=-1
kind_of_double = -1
call check_double(real4(1),real4(2),ret)
call check_double(real4(1), real4(2), ret)
if (ret == 't') then
kind_of_double=4
return
endif
kind_of_double = 4
return
end if
call check_double(real8(1),real8(2),ret)
call check_double(real8(1), real8(2), ret)
if (ret == 't') then
kind_of_double=8
return
endif
kind_of_double = 8
return
end if
end function kind_of_double
@ -140,22 +140,22 @@ program kind_h
real(kind=4), dimension(2) :: r4
real(kind=8), dimension(2) :: r8
print *,"integer,public,parameter :: kindOfInt=",kind_of_int()
print *,"integer,public,parameter :: kindOfLong=",kind_of_long()
print *,"integer,public,parameter :: kindOfSize_t=",kind_of_size_t()
print *,"integer,public,parameter :: kindOfSize=",kind_of_size_t()
print *,"integer,public,parameter :: kindOfDouble=",kind_of_double()
print *,"integer,public,parameter :: kindOfFloat=",kind_of_float()
call f_sizeof(i(1),i(2),size)
print *,"integer,public,parameter :: sizeOfInteger=",size
call f_sizeof(i2(1),i2(2),size)
print *,"integer,public,parameter :: sizeOfInteger2=",size
call f_sizeof(i4(1),i4(2),size)
print *,"integer,public,parameter :: sizeOfInteger4=",size
call f_sizeof(r4(1),r4(2),size)
print *,"integer,public,parameter :: sizeOfReal4=",size
call f_sizeof(r8(1),r8(2),size)
print *,"integer,public,parameter :: sizeOfReal8=",size
print *, "integer,public,parameter :: kindOfInt=", kind_of_int()
print *, "integer,public,parameter :: kindOfLong=", kind_of_long()
print *, "integer,public,parameter :: kindOfSize_t=", kind_of_size_t()
print *, "integer,public,parameter :: kindOfSize=", kind_of_size_t()
print *, "integer,public,parameter :: kindOfDouble=", kind_of_double()
print *, "integer,public,parameter :: kindOfFloat=", kind_of_float()
call f_sizeof(i(1), i(2), size)
print *, "integer,public,parameter :: sizeOfInteger=", size
call f_sizeof(i2(1), i2(2), size)
print *, "integer,public,parameter :: sizeOfInteger2=", size
call f_sizeof(i4(1), i4(2), size)
print *, "integer,public,parameter :: sizeOfInteger4=", size
call f_sizeof(r4(1), r4(2), size)
print *, "integer,public,parameter :: sizeOfReal4=", size
call f_sizeof(r8(1), r8(2), size)
print *, "integer,public,parameter :: sizeOfReal8=", size
end program kind_h

64
fortran/same_int_long.f90
View File

@ -12,25 +12,25 @@ integer function kind_of_long()
integer(8), dimension(2) :: x8 = (/1, 2/)
character(len=1) :: ret
kind_of_long=-1
kind_of_long = -1
call check_long(x2(1),x2(2),ret)
call check_long(x2(1), x2(2), ret)
if (ret == 't') then
kind_of_long=2
return
endif
kind_of_long = 2
return
end if
call check_long(x4(1),x4(2),ret)
call check_long(x4(1), x4(2), ret)
if (ret == 't') then
kind_of_long=4
return
endif
kind_of_long = 4
return
end if
call check_long(x8(1),x8(2),ret)
call check_long(x8(1), x8(2), ret)
if (ret == 't') then
kind_of_long=8
return
endif
kind_of_long = 8
return
end if
end function kind_of_long
@ -40,37 +40,37 @@ integer function kind_of_int()
integer(8), dimension(2) :: x8 = (/1, 2/)
character(len=1) :: ret
kind_of_int=-1
kind_of_int = -1
call check_int(x2(1),x2(2),ret)
call check_int(x2(1), x2(2), ret)
if (ret == 't') then
kind_of_int=2
return
endif
kind_of_int = 2
return
end if
call check_int(x4(1),x4(2),ret)
call check_int(x4(1), x4(2), ret)
if (ret == 't') then
kind_of_int=4
return
endif
kind_of_int = 4
return
end if
call check_int(x8(1),x8(2),ret)
call check_int(x8(1), x8(2), ret)
if (ret == 't') then
kind_of_int=8
return
endif
kind_of_int = 8
return
end if
end function kind_of_int
program same_int_long
integer ki,kl
integer ki, kl
ki=kind_of_int()
kl=kind_of_long()
ki = kind_of_int()
kl = kind_of_long()
if (ki /= kl) then
write (*,'(i1)') 0
write (*, '(i1)') 0
else
write (*,'(i1)') 1
endif
write (*, '(i1)') 1
end if
end program same_int_long

64
fortran/same_int_size_t.f90
View File

@ -12,25 +12,25 @@ integer function kind_of_size_t()
integer(8), dimension(2) :: x8 = (/1, 2/)
character(len=1) :: ret
kind_of_size_t=-1
kind_of_size_t = -1
call check_size_t(x2(1),x2(2),ret)
call check_size_t(x2(1), x2(2), ret)
if (ret == 't') then
kind_of_size_t=2
return
endif
kind_of_size_t = 2
return
end if
call check_size_t(x4(1),x4(2),ret)
call check_size_t(x4(1), x4(2), ret)
if (ret == 't') then
kind_of_size_t=4
return
endif
kind_of_size_t = 4
return
end if
call check_size_t(x8(1),x8(2),ret)
call check_size_t(x8(1), x8(2), ret)
if (ret == 't') then
kind_of_size_t=8
return
endif
kind_of_size_t = 8
return
end if
end function kind_of_size_t
@ -40,37 +40,37 @@ integer function kind_of_int()
integer(8), dimension(2) :: x8 = (/1, 2/)
character(len=1) :: ret
kind_of_int=-1
kind_of_int = -1
call check_int(x2(1),x2(2),ret)
call check_int(x2(1), x2(2), ret)
if (ret == 't') then
kind_of_int=2
return
endif
kind_of_int = 2
return
end if
call check_int(x4(1),x4(2),ret)
call check_int(x4(1), x4(2), ret)
if (ret == 't') then
kind_of_int=4
return
endif
kind_of_int = 4
return
end if
call check_int(x8(1),x8(2),ret)
call check_int(x8(1), x8(2), ret)
if (ret == 't') then
kind_of_int=8
return
endif
kind_of_int = 8
return
end if
end function kind_of_int
program same_int_size_t
integer ki,kl
integer ki, kl
ki=kind_of_int()
kl=kind_of_size_t()
ki = kind_of_int()
kl = kind_of_size_t()
if (ki /= kl) then
write (*,'(i1)') 0
write (*, '(i1)') 0
else
write (*,'(i1)') 1
endif
write (*, '(i1)') 1
end if
end program same_int_size_t

29
src/grib_accessor_class_data_ccsds_packing.c
View File

@ -324,7 +324,7 @@ static int pack_double(grib_accessor* a, const double* val, size_t* len)
grib_accessor_data_ccsds_packing* self = (grib_accessor_data_ccsds_packing*)a;
grib_handle* hand = grib_handle_of_accessor(a);
int err = GRIB_SUCCESS, i = 0;
int err = GRIB_SUCCESS, i = 0, is_constant_field = 0;
size_t buflen = 0;
unsigned char* buf = NULL;
@ -373,7 +373,23 @@ static int pack_double(grib_accessor* a, const double* val, size_t* len)
return GRIB_SUCCESS;
}
if (bits_per_value == 0) { /* constant field */
max = val[0];
min = max;
for (i = 1; i < n_vals; i++) {
if (val[i] > max) max = val[i];
else if (val[i] < min) min = val[i];
}
if (min == max) {
is_constant_field = 1;
} else {
if (bits_per_value == 0) {
/* ECC-1202: A non-constant field with bitsPerValue==0! */
bits_per_value = 24; /* Set sane value */
}
}
if (is_constant_field) {
#ifdef DEBUG
for (i = 1; i < n_vals; i++) {
Assert(val[i] == val[0]);
@ -401,15 +417,6 @@ static int pack_double(grib_accessor* a, const double* val, size_t* len)
return err;
d = grib_power(decimal_scale_factor, 10);
max = val[0];
min = max;
for (i = 1; i < n_vals; i++) {
if (val[i] > max)
max = val[i];
else if (val[i] < min)
min = val[i];
}
min *= d;
max *= d;

117
src/grib_util.c
View File

@ -11,6 +11,7 @@
#include "grib_api_internal.h"
#include <float.h>
#define STR_EQUAL(s1, s2) (strcmp((s1), (s2)) == 0)
typedef enum
{
@ -888,8 +889,8 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
size_t count = 0;
int i;
long editionNumber;
grib_handle* outh = NULL;
grib_handle* tmp = NULL;
grib_handle* h_out = NULL;
grib_handle* h_sample = NULL;
const char* grid_type = NULL;
char name[1024];
char input_grid_type[100];
@ -919,8 +920,7 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
/* Get edition number from input handle */
if ((*err = grib_get_long(h, "edition", &editionNumber)) != 0) {
grib_context* c = grib_context_get_default();
if (c->write_on_fail)
grib_write_message(h, "error.grib", "w");
if (c->write_on_fail) grib_write_message(h, "error.grib", "w");
return NULL;
}
@ -1026,10 +1026,8 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
if ((*err = grib_set_values(h, values, count)) != 0) {
fprintf(stderr, "GRIB_UTIL_SET_SPEC: Cannot set values %s\n", grib_get_error_message(*err));
for (i = 0; i < count; i++)
if (values[i].error)
fprintf(stderr, " %s %s\n", values[i].name, grib_get_error_message(values[i].error));
if (values[i].error) fprintf(stderr, " %s %s\n", values[i].name, grib_get_error_message(values[i].error));
goto cleanup;
}
if (h->context->debug == -1) {
@ -1090,7 +1088,7 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
}
return h;
}
} /* flags & GRIB_UTIL_SET_SPEC_FLAGS_ONLY_PACKING */
grid_type = get_grid_type_name(spec->grid_type);
if (grid_type == NULL) {
@ -1143,9 +1141,9 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
}
}
/* TODO: recycle tmp handle */
tmp = grib_handle_new_from_samples(NULL, name);
if (!tmp) {
/* TODO: recycle h_sample handle */
h_sample = grib_handle_new_from_samples(NULL, name);
if (!h_sample) {
*err = GRIB_INVALID_FILE;
return NULL;
}
@ -1447,6 +1445,8 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
}
}
/* ECC-1201: case of IEEE input ?? */
switch (packing_spec->accuracy) {
case GRIB_UTIL_ACCURACY_SAME_BITS_PER_VALUES_AS_INPUT: {
long bitsPerValue = 0;
@ -1470,7 +1470,7 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
default:
fprintf(stderr, "invalid packing_spec->accuracy = %ld\n", (long)packing_spec->accuracy);
grib_handle_delete(tmp);
grib_handle_delete(h_sample);
*err = GRIB_INTERNAL_ERROR;
goto cleanup;
break;
@ -1498,13 +1498,13 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
}
}
/* grib_write_message(h,"input.grib","w"); */
/* grib_write_message(tmp,"geo.grib","w"); */
/* copy product and local sections from h to tmp handle and store in outh */
if ((outh = grib_util_sections_copy(h, tmp, GRIB_SECTION_PRODUCT | GRIB_SECTION_LOCAL, err)) == NULL) {
/* grib_write_message(h_sample,"geo.grib","w"); */
/* copy product and local sections from h to h_sample handle and store in h_out */
if ((h_out = grib_util_sections_copy(h, h_sample, GRIB_SECTION_PRODUCT | GRIB_SECTION_LOCAL, err)) == NULL) {
goto cleanup;
}
grib_handle_delete(tmp);
grib_handle_delete(h_sample);
Assert(*err == 0);
/* Set "pl" array if provided (For reduced Gaussian grids) */
@ -1520,7 +1520,7 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
}
if (spec->pl_size != 0 && (spec->grid_type == GRIB_UTIL_GRID_SPEC_REDUCED_GG || spec->grid_type == GRIB_UTIL_GRID_SPEC_REDUCED_ROTATED_GG)) {
*err = grib_set_long_array(outh, "pl", spec->pl, spec->pl_size);
*err = grib_set_long_array(h_out, "pl", spec->pl, spec->pl_size);
if (*err) {
fprintf(stderr, "SET_GRID_DATA_DESCRIPTION: Cannot set pl %s\n", grib_get_error_message(*err));
goto cleanup;
@ -1544,32 +1544,30 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
/* Apply adjustments to bounding box if needed */
if (expandBoundingBox) {
if ((*err = expand_bounding_box(outh, values, count)) != 0) {
if ((*err = expand_bounding_box(h_out, values, count)) != 0) {
fprintf(stderr, "SET_GRID_DATA_DESCRIPTION: Cannot expand bounding box: %s\n", grib_get_error_message(*err));
if (h->context->write_on_fail)
grib_write_message(outh, "error.grib", "w");
grib_write_message(h_out, "error.grib", "w");
goto cleanup;
}
}
if (convertEditionEarlier && packing_spec->editionNumber > 1) {
*err = grib_set_long(outh, "edition", packing_spec->editionNumber);
*err = grib_set_long(h_out, "edition", packing_spec->editionNumber);
if (*err) {
fprintf(stderr, "SET_GRID_DATA_DESCRIPTION: Cannot convert to edition %ld.\n", packing_spec->editionNumber);
goto cleanup;
}
}
if ((*err = grib_set_values(outh, values, count)) != 0) {
if ((*err = grib_set_values(h_out, values, count)) != 0) {
fprintf(stderr, "SET_GRID_DATA_DESCRIPTION: Cannot set key values: %s\n", grib_get_error_message(*err));
for (i = 0; i < count; i++)
if (values[i].error)
fprintf(stderr, " %s %s\n", values[i].name, grib_get_error_message(values[i].error));
if (values[i].error) fprintf(stderr, " %s %s\n", values[i].name, grib_get_error_message(values[i].error));
goto cleanup;
}
if ((*err = grib_set_double_array(outh, "values", data_values, data_values_count)) != 0) {
if ((*err = grib_set_double_array(h_out, "values", data_values, data_values_count)) != 0) {
FILE* ferror;
size_t ii, lcount;
grib_context* c = grib_context_get_default();
@ -1588,67 +1586,66 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
}
fprintf(ferror, "%g }", data_values[data_values_count - 1]);
fclose(ferror);
if (c->write_on_fail)
grib_write_message(outh, "error.grib", "w");
if (c->write_on_fail) grib_write_message(h_out, "error.grib", "w");
goto cleanup;
}
/* grib_write_message(outh,"h.grib","w"); */
/* grib_write_message(h_out,"h.grib","w"); */
/* if the field is empty GRIBEX is packing as simple*/
/* if (!strcmp(input_packing_type,"grid_simple_matrix")) {
long numberOfValues;
grib_get_long(outh,"numberOfValues",&numberOfValues);
grib_get_long(h_out,"numberOfValues",&numberOfValues);
if (numberOfValues==0) {
slen=11;
grib_set_string(outh,"packingType","grid_simple",&slen);
grib_set_string(h_out,"packingType","grid_simple",&slen);
}
} */
if (grib1_high_resolution_fix) {
/* GRIB-863: must set increments to MISSING */
/* increments are not coded in message but computed */
if ((*err = grib_set_missing(outh, "iDirectionIncrement")) != 0) {
if ((*err = grib_set_missing(h_out, "iDirectionIncrement")) != 0) {
fprintf(stderr, "GRIB_UTIL_SET_SPEC: Cannot set Di to missing: %s\n", grib_get_error_message(*err));
goto cleanup;
}
if ((*err = grib_set_missing(outh, "jDirectionIncrement")) != 0) {
if ((*err = grib_set_missing(h_out, "jDirectionIncrement")) != 0) {
fprintf(stderr, "GRIB_UTIL_SET_SPEC: Cannot set Dj to missing: %s\n", grib_get_error_message(*err));
goto cleanup;
}
}
/*grib_dump_content(outh, stdout,"debug", ~0, NULL);*/
/*grib_dump_content(h_out, stdout,"debug", ~0, NULL);*/
/* convert to second_order if not constant field. (Also see ECC-326) */
if (setSecondOrder) {
int constant = 0;
double missingValue = 0;
grib_get_double(outh, "missingValue", &missingValue);
grib_get_double(h_out, "missingValue", &missingValue);
constant = is_constant_field(missingValue, data_values, data_values_count);
if (!constant) {
if (editionNumber == 1) {
long numberOfGroups = 0;
grib_handle* htmp = grib_handle_clone(outh);
grib_handle* htmp = grib_handle_clone(h_out);
slen = 17;
grib_set_string(htmp, "packingType", "grid_second_order", &slen);
grib_get_long(htmp, "numberOfGroups", &numberOfGroups);
/* GRIBEX is not able to decode overflown numberOfGroups with SPD */
if (numberOfGroups > 65534 && outh->context->no_spd) {
if (numberOfGroups > 65534 && h_out->context->no_spd) {
slen = 24;
grib_set_string(outh, "packingType", "grid_second_order_no_SPD", &slen);
grib_set_string(h_out, "packingType", "grid_second_order_no_SPD", &slen);
grib_handle_delete(htmp);
}
else {
grib_handle_delete(outh);
outh = htmp;
grib_handle_delete(h_out);
h_out = htmp;
}
}
else {
slen = 17;
grib_set_string(outh, "packingType", "grid_second_order", &slen);
*err = grib_set_double_array(outh, "values", data_values, data_values_count);
grib_set_string(h_out, "packingType", "grid_second_order", &slen);
*err = grib_set_double_array(h_out, "values", data_values, data_values_count);
if (*err != GRIB_SUCCESS) {
fprintf(stderr, "GRIB_UTIL_SET_SPEC: setting data values failed! %s\n", grib_get_error_message(*err));
goto cleanup;
@ -1656,21 +1653,21 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
}
}
else {
if (outh->context->gribex_mode_on) {
outh->context->gribex_mode_on = 0;
grib_set_double_array(outh, "values", data_values, data_values_count);
outh->context->gribex_mode_on = 1;
if (h_out->context->gribex_mode_on) {
h_out->context->gribex_mode_on = 0;
grib_set_double_array(h_out, "values", data_values, data_values_count);
h_out->context->gribex_mode_on = 1;
}
}
}
if (packing_spec->editionNumber && packing_spec->editionNumber != editionNumber) {
*err = grib_set_long(outh, "edition", packing_spec->editionNumber);
*err = grib_set_long(h_out, "edition", packing_spec->editionNumber);
if (*err != GRIB_SUCCESS) {
fprintf(stderr, "GRIB_UTIL_SET_SPEC: Failed to change edition to %ld: %s\n",
packing_spec->editionNumber, grib_get_error_message(*err));
if (h->context->write_on_fail)
grib_write_message(outh, "error.grib", "w");
grib_write_message(h_out, "error.grib", "w");
goto cleanup;
}
}
@ -1679,7 +1676,7 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
/* ECC-353 */
/* JPEG packing is not available in GRIB edition 1 and has to be done AFTER we set data values */
if (setJpegPacking == 1) {
*err = grib_set_string(outh, "packingType", "grid_jpeg", &slen);
*err = grib_set_string(h_out, "packingType", "grid_jpeg", &slen);
if (*err != GRIB_SUCCESS) {
fprintf(stderr, "GRIB_UTIL_SET_SPEC: Failed to change packingType to JPEG: %s\n",
grib_get_error_message(*err));
@ -1687,7 +1684,7 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
}
}
if (setCcsdsPacking == 1) {
*err = grib_set_string(outh, "packingType", "grid_ccsds", &slen);
*err = grib_set_string(h_out, "packingType", "grid_ccsds", &slen);
if (*err != GRIB_SUCCESS) {
fprintf(stderr, "GRIB_UTIL_SET_SPEC: Failed to change packingType to CCSDS: %s\n",
grib_get_error_message(*err));
@ -1697,7 +1694,7 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
}
if (packing_spec->deleteLocalDefinition) {
grib_set_long(outh, "deleteLocalDefinition", 1);
grib_set_long(h_out, "deleteLocalDefinition", 1);
}
/* ECC-445 */
@ -1705,36 +1702,32 @@ grib_handle* grib_util_set_spec2(grib_handle* h,
Assert(!global_grid); /* ECC-576: "global" should not be set */
}
if ((*err = check_geometry(outh, spec, data_values_count, global_grid)) != GRIB_SUCCESS) {
if ((*err = check_geometry(h_out, spec, data_values_count, global_grid)) != GRIB_SUCCESS) {
fprintf(stderr, "GRIB_UTIL_SET_SPEC: Geometry check failed! %s\n", grib_get_error_message(*err));
if (h->context->write_on_fail)
grib_write_message(outh, "error.grib", "w");
grib_write_message(h_out, "error.grib", "w");
goto cleanup;
}
/* Disable check: need to re-examine GRIB-864 */
#if 0
if ( (*err = check_handle_against_spec(outh, editionNumber, spec, global_grid)) != GRIB_SUCCESS)
{
if ( (*err = check_handle_against_spec(h_out, editionNumber, spec, global_grid)) != GRIB_SUCCESS) {
grib_context* c=grib_context_get_default();
fprintf(stderr,"GRIB_UTIL_SET_SPEC: Geometry check failed! %s\n", grib_get_error_message(*err));
if (editionNumber == 1) {
fprintf(stderr,"Note: in GRIB edition 1 latitude and longitude values cannot be represented with sub-millidegree precision.\n");
}
if (c->write_on_fail)
grib_write_message(outh,"error.grib","w");
if (c->write_on_fail) grib_write_message(h_out,"error.grib","w");
goto cleanup;
}
#endif
if (h->context->debug == -1)
fprintf(stderr, "ECCODES DEBUG: grib_util_set_spec end\n");
if (h->context->debug == -1) fprintf(stderr, "ECCODES DEBUG: grib_util_set_spec end\n");
return outh;
return h_out;
cleanup:
if (outh)
grib_handle_delete(outh);
if (h_out)
grib_handle_delete(h_out);
return NULL;
}

1
tests/CMakeLists.txt
View File

@ -23,6 +23,7 @@ list(APPEND test_bins
gauss_sub
grib_nearest_test
grib_util_set_spec
grib_check_param_concepts
grib_local_MeteoFrance
grib_2nd_order_numValues
grib_optimize_scaling

20
tests/grib_ccsds.sh
View File

@ -32,10 +32,8 @@ ${tools_dir}/grib_set -r -s packingType=grid_ccsds $outfile1 $outfile2
${tools_dir}/grib_compare -b $BLACKLIST $outfile1 $outfile2 > $REDIRECT
templateNumber=`${tools_dir}/grib_get -p dataRepresentationTemplateNumber $outfile2`
if [ $templateNumber -ne 42 ]
then
echo dataRepresentationTemplateNumber=$templateNumber
if [ $templateNumber -ne 42 ]; then
echo "dataRepresentationTemplateNumber=$templateNumber. Should be 42!"
exit 1
fi
@ -58,7 +56,8 @@ res3=`${tools_dir}/grib_get '-F%1.2f' -p min,max,avg $outfile2`
rm -f $outfile1 $outfile2
# ECC-297
# ECC-297: Basic support
# --------------------------------------
infile=${data_dir}/tigge_ecmwf.grib2
outfile1=$infile.tmp_ccsds.1
outfile2=$infile.tmp_ccsds.2
@ -68,10 +67,21 @@ ${tools_dir}/grib_set -r -s packingType=grid_ccsds $outfile1 $outfile2
${tools_dir}/grib_compare -c data:n $outfile1 $outfile2
# ECC-477: redundant error message during conversion
# ---------------------------------------------------
infile=${data_dir}/ccsds.grib2
rm -f $outfile2
${tools_dir}/grib_set -r -s packingType=grid_simple $infile $outfile1 >$outfile2 2>&1
# there should be no error messages printed (to stdout or stderr)
[ ! -s $outfile2 ]
# ECC-1202: Check input packingType=grid_ieee
# --------------------------------------------
infile=${data_dir}/grid_ieee.grib
${tools_dir}/grib_set -r -s packingType=grid_ccsds $infile $outfile1
grib_check_key_equals $outfile1 packingType grid_ccsds
${tools_dir}/grib_set -r -s packingType=grid_simple $infile $outfile2
${tools_dir}/grib_compare -c data:n $outfile1 $outfile2
# Clean up
rm -f $outfile1 $outfile2

143
tests/grib_check_param_concepts.c Normal file
View File

@ -0,0 +1,143 @@
/*
* (C) Copyright 2005- ECMWF.
*
* This software is licensed under the terms of the Apache Licence Version 2.0
* which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
*
* In applying this licence, ECMWF does not waive the privileges and immunities granted to it by
* virtue of its status as an intergovernmental organisation nor does it submit to any jurisdiction.
*/
/*
* Check GRIB2 parameter concept file e.g. shortName.def, paramId.def
*/
#include <assert.h>
#include "grib_api_internal.h"
typedef struct grib_expression_long {
grib_expression base;
long value;
} grib_expression_long;
typedef struct grib_expression_functor {
grib_expression base;
char* name;
grib_arguments* args;
} grib_expression_functor;
typedef struct grib_expression_string {
grib_expression base;
char* value;
} grib_expression_string;
static int type_of_surface_missing(const char* value)
{
/* Surface Type is Code Table 4.5 in which 255 is the same as missing */
if (strcmp(value, "missing") == 0 || strcmp(value, "255") == 0) {
return 1;
}
return 0;
}
static int scale_factor_missing(const char* value)
{
/* Scale factor is one octet so 255 is the same as missing */
if (strcmp(value, "missing") == 0 || strcmp(value, "255") == 0) {
return 1;
}
return 0;
}
static int grib_check_param_concepts(const char* key, const char* filename)
{
grib_concept_value* concept_value = grib_parse_concept_file(NULL, filename);
if (!concept_value)
return GRIB_IO_PROBLEM;
while (concept_value) {
grib_concept_condition* concept_condition = concept_value->conditions;
/* Convention:
* -1 key not present
* 0 key present and not missing
* 1 key present and missing
*/
int scaleFactor1Missing = -1, scaleFactor2Missing = -1;
int scaledValue1Missing = -1, scaledValue2Missing = -1;
int type1Missing = -1, type2Missing = -1;
int err = 0;
/* concept_value->name is the value of the key e.g. 151163 */
while (concept_condition) {
char condition_value[512] = {0,};
grib_expression* expression = concept_condition->expression;
const char* condition_name = concept_condition->name;
/* condition_name is discipline, parameterCategory etc. */
if (strcmp(expression->cclass->name, "long") == 0) {
grib_expression_long* el = (grib_expression_long*)expression;
sprintf(condition_value, "%ld", el->value);
}
else if (strcmp(expression->cclass->name, "functor") == 0) {
grib_expression_functor* ef = (grib_expression_functor*)expression;
sprintf(condition_value, "%s", ef->name);
}
else if (strcmp(expression->cclass->name, "string") == 0) {
grib_expression_string* es = (grib_expression_string*)expression;
sprintf(condition_value, "%s", es->value);
}
else {
Assert(0);
}
if (strcmp(condition_name, "typeOfFirstFixedSurface") == 0) {
type1Missing = type_of_surface_missing(condition_value);
}
if (strcmp(condition_name, "typeOfSecondFixedSurface") == 0) {
type2Missing = type_of_surface_missing(condition_value);
}
if (strcmp(condition_name, "scaleFactorOfFirstFixedSurface") == 0) {
scaleFactor1Missing = scale_factor_missing(condition_value);
}
if (strcmp(condition_name, "scaleFactorOfSecondFixedSurface") == 0) {
scaleFactor2Missing = scale_factor_missing(condition_value);
}
if (strcmp(condition_name, "scaledValueOfFirstFixedSurface") == 0) {
scaledValue1Missing = (strcmp(condition_value, "missing") == 0);
}
if (strcmp(condition_name, "scaledValueOfSecondFixedSurface") == 0) {
scaledValue2Missing = (strcmp(condition_value, "missing") == 0);
}
concept_condition = concept_condition->next;
}
/* Now check the scale factor/value pairs */
if (type1Missing == 1 && scaleFactor1Missing == 0 && scaledValue1Missing == 0) err = 1;
if (type2Missing == 1 && scaleFactor2Missing == 0 && scaledValue2Missing == 0) err = 1;
if (scaleFactor1Missing == 1 && scaledValue1Missing == 0) err = 1;
if (scaleFactor1Missing == 0 && scaledValue1Missing == 1) err = 1;
if (scaleFactor2Missing == 1 && scaledValue2Missing == 0) err = 1;
if (scaleFactor2Missing == 0 && scaledValue2Missing == 1) err = 1;
if (err) {
fprintf(stderr,
"Error: Mismatched type of surface, scale factor, scaled value keys for %s='%s'.\n"
" If the type of surface is missing so should its scaled keys\n"
" If the scale factor is missing so should the scaled value and vice versa\n",
key, concept_value->name);
return GRIB_INVALID_KEY_VALUE;
}
concept_value = concept_value->next;
}
return GRIB_SUCCESS;
}
int main(int argc, char** argv)
{
int err = 0;
const char* concepts_key = argv[1];
const char* concepts_filename = argv[2];
assert(argc == 3);
err = grib_check_param_concepts(concepts_key, concepts_filename);
if (err) return err;
printf("ALL OK\n");
return 0;
}

17
tests/grib_check_param_concepts.sh
View File

@ -10,12 +10,21 @@
. ./include.sh
REDIRECT=/dev/null
# This script will check the following concept files:
# name.def paramId.def shortName.def units.def cfVarName.def
#
# Do various checks on the concepts files
#
# First check the GRIB2 paramId.def and shortName.def
# ----------------------------------------------------
$EXEC ${test_dir}/grib_check_param_concepts paramId $ECCODES_DEFINITION_PATH/grib2/paramId.def
$EXEC ${test_dir}/grib_check_param_concepts paramId $ECCODES_DEFINITION_PATH/grib2/localConcepts/ecmf/paramId.def
$EXEC ${test_dir}/grib_check_param_concepts shortName $ECCODES_DEFINITION_PATH/grib2/shortName.def
$EXEC ${test_dir}/grib_check_param_concepts shortName $ECCODES_DEFINITION_PATH/grib2/localConcepts/ecmf/shortName.def
# Check the group: name.def paramId.def shortName.def units.def cfVarName.def
# ----------------------------------------------------------------------------
# Check whether the Test::More Perl module is available
set +e
perl -e 'use Test::More;'

1
tests/unit_tests.c
View File

@ -1475,7 +1475,6 @@ static void test_concept_condition_strings()
err = get_concept_condition_string(h, "gridType", NULL, result);
Assert(!err);
/*printf("%s\n", result);*/
Assert(strcmp(result, "gridDefinitionTemplateNumber=0,PLPresent=0") == 0);
err = get_concept_condition_string(h, "stepType", NULL, result);