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

Examples: Fortran formatting (https://github.com/pseewald/fprettify)

This commit is contained in:
Shahram Najm 2021-02-14 18:14:39 +00:00
parent af65489218
commit 9fdc2b50c5
56 changed files with 2597 additions and 2612 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

168
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)
deallocate(level)
deallocate(shortName)
deallocate(step)
deallocate(number)
call codes_index_release(idx)
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