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

60
examples/F90/bufr_clone.f90
View File

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

126
examples/F90/bufr_copy_data.f90
View File

@ -15,72 +15,72 @@
! !
program bufr_encode program bufr_encode
use eccodes use eccodes
implicit none implicit none
integer :: iret integer :: iret
integer :: outfile integer :: outfile
integer :: ifile integer :: ifile
integer :: ibufr integer :: ibufr
integer :: ibufrin integer :: ibufrin
integer(kind=4), dimension(:), allocatable :: ivalues integer(kind=4), dimension(:), allocatable :: ivalues
integer, parameter :: max_strsize = 200 integer, parameter :: max_strsize = 200
character(len=max_strsize) :: infile_name character(len=max_strsize) :: infile_name
character(len=max_strsize) :: outfile_name character(len=max_strsize) :: outfile_name
call codes_bufr_new_from_samples(ibufr,'BUFR3',iret) call codes_bufr_new_from_samples(ibufr, 'BUFR3', iret)
call getarg(1, infile_name) call getarg(1, infile_name)
call getarg(2, outfile_name) call getarg(2, outfile_name)
call codes_open_file(ifile, infile_name, 'r') call codes_open_file(ifile, infile_name, 'r')
call codes_bufr_new_from_file(ifile, ibufrin) call codes_bufr_new_from_file(ifile, ibufrin)
if (iret/=CODES_SUCCESS) then if (iret /= CODES_SUCCESS) then
print *,'ERROR creating BUFR from BUFR3' print *, 'ERROR creating BUFR from BUFR3'
stop 1 stop 1
endif end if
if(allocated(ivalues)) deallocate(ivalues) if (allocated(ivalues)) deallocate (ivalues)
allocate(ivalues(69)) allocate (ivalues(69))
ivalues=(/ & ivalues = (/ &
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
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, & 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, 1, 1, 1, 1, 1, &
1, 1, 1, 1, 1, 0, 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, 1, 1, &
1, 1, 1, 1, 1, 1, 1, 1, 0 /) 1, 1, 1, 1, 1, 1, 1, 1, 0/)
call codes_set(ibufr,'inputDataPresentIndicator',ivalues) call codes_set(ibufr, 'inputDataPresentIndicator', ivalues)
call codes_set(ibufr,'edition',3) call codes_set(ibufr, 'edition', 3)
call codes_set(ibufr,'masterTableNumber',0) call codes_set(ibufr, 'masterTableNumber', 0)
call codes_set(ibufr,'bufrHeaderSubCentre',0) call codes_set(ibufr, 'bufrHeaderSubCentre', 0)
call codes_set(ibufr,'bufrHeaderCentre',98) call codes_set(ibufr, 'bufrHeaderCentre', 98)
call codes_set(ibufr,'updateSequenceNumber',1) call codes_set(ibufr, 'updateSequenceNumber', 1)
call codes_set(ibufr,'dataCategory',0) call codes_set(ibufr, 'dataCategory', 0)
call codes_set(ibufr,'dataSubCategory',140) call codes_set(ibufr, 'dataSubCategory', 140)
call codes_set(ibufr,'masterTablesVersionNumber',13) call codes_set(ibufr, 'masterTablesVersionNumber', 13)
call codes_set(ibufr,'localTablesVersionNumber',1) call codes_set(ibufr, 'localTablesVersionNumber', 1)
call codes_set(ibufr,'typicalYearOfCentury',15) call codes_set(ibufr, 'typicalYearOfCentury', 15)
call codes_set(ibufr,'typicalMonth',5) call codes_set(ibufr, 'typicalMonth', 5)
call codes_set(ibufr,'typicalDay',4) call codes_set(ibufr, 'typicalDay', 4)
call codes_set(ibufr,'typicalHour',9) call codes_set(ibufr, 'typicalHour', 9)
call codes_set(ibufr,'typicalMinute',30) call codes_set(ibufr, 'typicalMinute', 30)
call codes_set(ibufr,'numberOfSubsets',1) call codes_set(ibufr, 'numberOfSubsets', 1)
call codes_set(ibufr,'observedData',1) call codes_set(ibufr, 'observedData', 1)
call codes_set(ibufr,'compressedData',0) call codes_set(ibufr, 'compressedData', 0)
if(allocated(ivalues)) deallocate(ivalues) if (allocated(ivalues)) deallocate (ivalues)
allocate(ivalues(43)) allocate (ivalues(43))
ivalues=(/ & ivalues = (/ &
307011,7006,10004,222000,101023,31031,1031,1032,101023,33007, & 307011, 7006, 10004, 222000, 101023, 31031, 1031, 1032, 101023, 33007, &
225000,236000,101023,31031,1031,1032,8024,101001,225255,225000, & 225000, 236000, 101023, 31031, 1031, 1032, 8024, 101001, 225255, 225000, &
236000,101023,31031,1031,1032,8024,101001,225255, & 236000, 101023, 31031, 1031, 1032, 8024, 101001, 225255, &
1063,2001,4001,4002,4003,4004,4005,5002, & 1063, 2001, 4001, 4002, 4003, 4004, 4005, 5002, &
6002,7001,7006,11001,11016,11017,11002 /) 6002, 7001, 7006, 11001, 11016, 11017, 11002/)
call codes_set(ibufr,'unexpandedDescriptors',ivalues) 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_open_file(outfile, outfile_name, 'w')
call codes_write(ibufr,outfile) call codes_write(ibufr, outfile)
call codes_close_file(outfile) call codes_close_file(outfile)
call codes_release(ibufr) call codes_release(ibufr)
end program bufr_encode 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. ! Description: how to copy a BUFR key from a message to another.
! !
program bufr_copy_keys program bufr_copy_keys
use eccodes use eccodes
implicit none implicit none
integer :: file1, file2, file3 integer :: file1, file2, file3
integer :: ibufr1,ibufr2,ibufr3 integer :: ibufr1, ibufr2, ibufr3
call codes_open_file(file1, '../../data/bufr/PraticaTemp.bufr', 'r') 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(file2, '../../data/bufr/aaen_55.bufr', 'r')
call codes_open_file(file3, 'out.bufr_copy_keys_test_f.bufr', 'w') 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(file1, ibufr1)
call codes_bufr_new_from_file(file2, ibufr2) 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(file1)
call codes_close_file(file2) call codes_close_file(file2)
call codes_close_file(file3) call codes_close_file(file3)
end program bufr_copy_keys end program bufr_copy_keys

58
examples/F90/bufr_copy_message.f90
View File

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

69
examples/F90/bufr_expanded.f90
View File

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

119
examples/F90/bufr_get_keys.f90
View File

@ -13,86 +13,85 @@
! !
! !
program bufr_get_keys program bufr_get_keys
use eccodes use eccodes
implicit none implicit none
integer :: ifile integer :: ifile
integer :: iret integer :: iret
integer :: ibufr integer :: ibufr
integer :: i, count=0 integer :: i, count = 0
integer(kind=4) :: blockNumber,stationNumber integer(kind=4) :: blockNumber, stationNumber
real(kind=8) :: t2m real(kind=8) :: t2m
integer(kind=4), dimension(:), allocatable :: descriptors integer(kind=4), dimension(:), allocatable :: descriptors
real(kind=8), dimension(:), allocatable :: values real(kind=8), dimension(:), allocatable :: values
character(len=9) :: typicalDate 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, ! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls ! 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 ! Get and print some keys form the BUFR header
write(*,*) 'message: ',count write (*, *) 'message: ', count
! We need to instruct ecCodes to expand all the descriptors ! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values ! i.e. unpack the data values
call codes_set(ibufr,"unpack",1); call codes_set(ibufr, "unpack", 1);
! Get as character
call codes_get(ibufr, 'typicalDate', typicalDate)
write (*, *) ' typicalDate:', typicalDate
! Get as character ! Get as integer
call codes_get(ibufr,'typicalDate',typicalDate) call codes_get(ibufr, 'blockNumber', blockNumber);
write(*,*) ' typicalDate:',typicalDate write (*, *) ' blockNumber:', blockNumber
! Get as integer ! Get as integer
call codes_get(ibufr,'blockNumber',blockNumber); call codes_get(ibufr, 'stationNumber', stationNumber);
write(*,*) ' blockNumber:',blockNumber write (*, *) ' stationNumber:', stationNumber
! Get as integer ! get as real
call codes_get(ibufr,'stationNumber',stationNumber); call codes_get(ibufr, 'airTemperatureAt2M', t2m);
write(*,*) ' stationNumber:',stationNumber write (*, *) ' airTemperatureAt2M:', t2m
! get as real ! ---- array of integer ----------------
call codes_get(ibufr,'airTemperatureAt2M',t2m);
write(*,*) ' airTemperatureAt2M:',t2m
! ---- array of integer ---------------- ! get the expanded descriptors
call codes_get(ibufr, 'bufrdcExpandedDescriptors', descriptors)
! get the expanded descriptors do i = 1, size(descriptors)
call codes_get(ibufr,'bufrdcExpandedDescriptors',descriptors) write (*, *) ' ', i, descriptors(i)
end do
do i=1,size(descriptors) ! ---- array of real ----------------
write(*,*) ' ',i,descriptors(i)
enddo
! ---- array of real ---------------- ! Get the expanded data values
call codes_get(ibufr, 'numericValues', values)
! Get the expanded data values do i = 1, size(values)
call codes_get(ibufr,'numericValues',values) write (*, *) ' ', i, values(i)
end do
do i=1,size(values) ! Get as character
write(*,*) ' ',i,values(i) call codes_get(ibufr, 'typicalDate', typicalDate)
enddo write (*, *) ' typicalDate:', typicalDate
! Get as character ! Free arrays
call codes_get(ibufr,'typicalDate',typicalDate) deallocate (values)
write(*,*) ' typicalDate:',typicalDate deallocate (descriptors)
! Free arrays ! Release the bufr message
deallocate(values) call codes_release(ibufr)
deallocate(descriptors)
! Release the bufr message ! Load the next bufr message
call codes_release(ibufr) call codes_bufr_new_from_file(ifile, ibufr, iret)
! Load the next bufr message count = count + 1
call codes_bufr_new_from_file(ifile,ibufr,iret)
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 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. ! Description: how to get an array of strings from a BUFR message.
program bufr_get_string_array program bufr_get_string_array
use eccodes use eccodes
implicit none implicit none
integer :: ifile integer :: ifile
integer :: iret,i,n integer :: iret, i, n
integer :: ibufr integer :: ibufr
integer :: strsize integer :: strsize
integer, parameter :: max_strsize = 20 integer, parameter :: max_strsize = 20
character(len=max_strsize) , dimension(:),allocatable :: stationOrSiteName 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 ! Unpack the data values
call codes_set(ibufr,'unpack',1) call codes_set(ibufr, 'unpack', 1)
! Get the width of the strings which is the same for all of them ! Get the width of the strings which is the same for all of them
call codes_get(ibufr,'stationOrSiteName->width',strsize) call codes_get(ibufr, 'stationOrSiteName->width', strsize)
! The width is given in bits ! The width is given in bits
strsize=strsize/8 strsize = strsize/8
! max_strsize has to be set to a value >= to the size of the strings that we are getting ! 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 ! back from the call to codes_get_string_array
if (strsize > max_strsize) then if (strsize > max_strsize) then
print *,'stationOrSiteName array dimension is ',max_strsize,' and should be ',strsize print *, 'stationOrSiteName array dimension is ', max_strsize, ' and should be ', strsize
call exit(1) call exit(1)
end if end if
! Allocating the array of strings to be passed to codes_get_string_array is mandatory ! Allocating the array of strings to be passed to codes_get_string_array is mandatory
call codes_get_size(ibufr,'stationOrSiteName',n) call codes_get_size(ibufr, 'stationOrSiteName', n)
allocate(stationOrSiteName(n)) allocate (stationOrSiteName(n))
! Passing an array of strings stationOrSiteName which must be allocated beforehand ! Passing an array of strings stationOrSiteName which must be allocated beforehand
call codes_get_string_array(ibufr,'stationOrSiteName',stationOrSiteName) call codes_get_string_array(ibufr, 'stationOrSiteName', stationOrSiteName)
do i=1,n do i = 1, n
write(*,'(A)')trim(stationOrSiteName(i)) write (*, '(A)') trim(stationOrSiteName(i))
end do end do
! Remember to deallocate ! Remember to deallocate
deallocate(stationOrSiteName) deallocate (stationOrSiteName)
! Release memory associated with bufr handle ! Release memory associated with bufr handle
! ibufr won't be accessible after this ! ibufr won't be accessible after this
call codes_release(ibufr) call codes_release(ibufr)
! Close file ! Close file
call codes_close_file(ifile) call codes_close_file(ifile)
end program bufr_get_string_array end program bufr_get_string_array

89
examples/F90/bufr_keys_iterator.f90
View File

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

82
examples/F90/bufr_read_header.f90
View File

@ -13,63 +13,63 @@
! !
! !
program bufr_read_header program bufr_read_header
use eccodes use eccodes
implicit none implicit none
integer :: ifile integer :: ifile
integer :: iret integer :: iret
integer :: ibufr integer :: ibufr
integer :: count=0 integer :: count = 0
integer(kind=4) :: dataCategory,dataSubCategory,typicalDate integer(kind=4) :: dataCategory, dataSubCategory, typicalDate
integer(kind=4) :: centre,subcentre integer(kind=4) :: centre, subcentre
integer(kind=4) :: masterversion,localversion integer(kind=4) :: masterversion, localversion
integer(kind=4) :: numberOfSubsets 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, ! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls ! 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 ! Get and print some keys form the BUFR header
write(*,*) 'message: ',count write (*, *) 'message: ', count
call codes_get(ibufr,'dataCategory',dataCategory); call codes_get(ibufr, 'dataCategory', dataCategory);
write(*,*) ' dataCategory:',dataCategory write (*, *) ' dataCategory:', dataCategory
call codes_get(ibufr,'dataSubCategory',dataSubCategory); call codes_get(ibufr, 'dataSubCategory', dataSubCategory);
write(*,*) ' dataSubCategory:',dataSubCategory write (*, *) ' dataSubCategory:', dataSubCategory
call codes_get(ibufr,'typicalDate',typicalDate); call codes_get(ibufr, 'typicalDate', typicalDate);
write(*,*) ' typicalDate:',typicalDate write (*, *) ' typicalDate:', typicalDate
call codes_get(ibufr,'bufrHeaderCentre',centre); call codes_get(ibufr, 'bufrHeaderCentre', centre);
write(*,*) ' bufrHeaderCentre:',centre write (*, *) ' bufrHeaderCentre:', centre
call codes_get(ibufr,'bufrHeaderSubCentre',subcentre) call codes_get(ibufr, 'bufrHeaderSubCentre', subcentre)
write(*,*) ' bufrHeaderSubCentre:',subcentre write (*, *) ' bufrHeaderSubCentre:', subcentre
call codes_get(ibufr,'masterTablesVersionNumber',masterversion) call codes_get(ibufr, 'masterTablesVersionNumber', masterversion)
write(*,*) ' masterTablesVersionNumber:',masterversion write (*, *) ' masterTablesVersionNumber:', masterversion
call codes_get(ibufr,'localTablesVersionNumber',localversion) call codes_get(ibufr, 'localTablesVersionNumber', localversion)
write(*,*) ' localTablesVersionNumber:',localversion write (*, *) ' localTablesVersionNumber:', localversion
call codes_get(ibufr,'numberOfSubsets',numberOfSubsets) call codes_get(ibufr, 'numberOfSubsets', numberOfSubsets)
write(*,*) ' numberOfSubsets:',numberOfSubsets write (*, *) ' numberOfSubsets:', numberOfSubsets
! Release the bufr message ! Release the bufr message
call codes_release(ibufr) call codes_release(ibufr)
! Load the next bufr message ! 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 end do
! Close file ! Close file
call codes_close_file(ifile) call codes_close_file(ifile)
end program bufr_read_header 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 ! 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. ! example. It is advised to use bufr_dump first to understand the structure of these messages.
program bufr_read_scatterometer program bufr_read_scatterometer
use eccodes use eccodes
implicit none implicit none
integer :: ifile integer :: ifile
integer :: iret integer :: iret
integer :: ibufr integer :: ibufr
integer :: i, count=0 integer :: i, count = 0
integer(kind=4) :: numObs,ii integer(kind=4) :: numObs, ii
real(kind=8), dimension(:), allocatable :: latVal,lonVal,bscatterVal real(kind=8), dimension(:), allocatable :: latVal, lonVal, bscatterVal
real(kind=8), dimension(:), allocatable :: year 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, ! The first BUFR message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls ! 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)') 'message: ',count write (*, '(A,I3)') 'message: ', count
! We need to instruct ecCodes to expand all the descriptors ! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values ! i.e. unpack the data values
call codes_set(ibufr,"unpack",1); 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. ! Read the total number of subsets.
! It means each subset has exactly the same structure: they store one location with call codes_get(ibufr, 'numberOfSubsets', numObs)
! 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. write (*, '(A,I5)') "Number of values:", numObs
call codes_get(ibufr,'numberOfSubsets',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) ! Get backScatter for beam two. We use an access by condition for this key.
call codes_get(ibufr,'latitude',latVal); ! (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) ! Print the values
call codes_get(ibufr,'longitude',lonVal); write (*, *) 'pixel lat lon backscatter'
write (*, *) "--------------------------------------"
allocate(year(numObs)) do i = 1, numObs
call codes_get(ibufr,'year',year); write (*, '(I4,3F10.5)') i, latVal(i), lonVal(i), bscatterVal(i)
do ii= 1, size(year) end do
write(*,'(A,I4,A,F8.1)') 'year(',ii,')=',year(ii)
enddo
! Get backScatter for beam two. We use an access by condition for this key. ! Free arrays
! (for all the subsets) deallocate (latVal)
call codes_get(ibufr,'/beamIdentifier=2/backscatter',bscatterVal); deallocate (lonVal)
deallocate (bscatterVal)
! Check that all arrays are same size ! Release the bufr message
if (size(latVal)/= numObs .or. size(lonVal)/= numObs .or. size(bscatterVal)/= numObs) then call codes_release(ibufr)
print *,'inconsistent array dimension'
exit
endif
! Print the values ! Load the next bufr message
write(*,*) 'pixel lat lon backscatter' call codes_bufr_new_from_file(ifile, ibufr, iret)
write(*,*) "--------------------------------------"
do i=1,numObs count = count + 1
write(*,'(I4,3F10.5)') i,latVal(i),lonVal(i),bscatterVal(i)
end do
! Free arrays end do
deallocate(latVal)
deallocate(lonVal)
deallocate(bscatterVal)
! Release the bufr message ! Close file
call codes_release(ibufr) call codes_close_file(ifile)
! 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_scatterometer end program bufr_read_scatterometer

144
examples/F90/bufr_read_synop.f90
View File

@ -18,102 +18,102 @@
! !
! !
program bufr_read_synop program bufr_read_synop
use eccodes use eccodes
implicit none implicit none
integer :: ifile integer :: ifile
integer :: iret integer :: iret
integer :: ibufr integer :: ibufr
integer :: count=0 integer :: count = 0
integer(kind=4) :: blockNumber,stationNumber integer(kind=4) :: blockNumber, stationNumber
real(kind=8) :: lat,t2m,td2m,ws,wdir real(kind=8) :: lat, t2m, td2m, ws, wdir
integer(kind=4) :: cloudAmount,cloudBaseHeight,lowCloud,midCloud,highCloud 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, ! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls ! 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(*,*) 'message: ',count write (*, *) 'message: ', count
! We need to instruct ecCodes to expand all the descriptors ! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values ! i.e. unpack the data values
call codes_set(ibufr,"unpack",1) call codes_set(ibufr, "unpack", 1)
!read and print some data values. This example was written !read and print some data values. This example was written
! for a SYNOP BUFR file! ! for a SYNOP BUFR file!
! wmo block number ! wmo block number
call codes_get(ibufr,'blockNumber',blockNumber) call codes_get(ibufr, 'blockNumber', blockNumber)
write(*,*) ' blockNumber:',blockNumber write (*, *) ' blockNumber:', blockNumber
! station number ! station number
call codes_get(ibufr,'stationNumber',stationNumber) call codes_get(ibufr, 'stationNumber', stationNumber)
write(*,*) ' stationNumber:',stationNumber write (*, *) ' stationNumber:', stationNumber
! location ! location
call codes_get(ibufr,'latitude',lat) call codes_get(ibufr, 'latitude', lat)
write(*,*) ' latitude:',lat write (*, *) ' latitude:', lat
call codes_get(ibufr,'longitude',lat) call codes_get(ibufr, 'longitude', lat)
write(*,*) ' longitude:',lat write (*, *) ' longitude:', lat
! 2m temperature ! 2m temperature
call codes_get(ibufr,'airTemperatureAt2M',t2m); call codes_get(ibufr, 'airTemperatureAt2M', t2m);
write(*,*) ' airTemperatureAt2M:',t2m write (*, *) ' airTemperatureAt2M:', t2m
! 2m dewpoint temperature ! 2m dewpoint temperature
call codes_get(ibufr,'dewpointTemperatureAt2M',td2m); call codes_get(ibufr, 'dewpointTemperatureAt2M', td2m);
write(*,*) ' dewpointTemperatureAt2M:',td2m write (*, *) ' dewpointTemperatureAt2M:', td2m
! 10m wind ! 10m wind
call codes_get(ibufr,'windSpeedAt10M',ws); call codes_get(ibufr, 'windSpeedAt10M', ws);
write(*,*) ' windSpeedAt10M:',ws write (*, *) ' windSpeedAt10M:', ws
call codes_get(ibufr,'windDirectionAt10M',wdir); call codes_get(ibufr, 'windDirectionAt10M', wdir);
write(*,*) ' windDirectionAt10M:',wdir write (*, *) ' windDirectionAt10M:', wdir
! The cloud information is stored in several blocks in the ! The cloud information is stored in several blocks in the
! SYNOP message and the same key means a different thing in different ! SYNOP message and the same key means a different thing in different
! parts of the message. In this example we will read the first ! parts of the message. In this example we will read the first
! cloud block introduced by the key ! cloud block introduced by the key
! verticalSignificanceSurfaceObservations=1. ! verticalSignificanceSurfaceObservations=1.
! We know that this is the first occurrence of the keys we want to ! We know that this is the first occurrence of the keys we want to
! read so we will use the # (occurrence) operator accordingly. ! read so we will use the # (occurrence) operator accordingly.
! Cloud amount (low and middleclouds) ! Cloud amount (low and middleclouds)
call codes_get(ibufr,'#1#cloudAmount',cloudAmount) call codes_get(ibufr, '#1#cloudAmount', cloudAmount)
write(*,*) ' cloudAmount (low and middle):',cloudAmount write (*, *) ' cloudAmount (low and middle):', cloudAmount
! Height of cloud base ! Height of cloud base
call codes_get(ibufr,'#1#heightOfBaseOfCloud',cloudBaseHeight) call codes_get(ibufr, '#1#heightOfBaseOfCloud', cloudBaseHeight)
write(*,*) ' heightOfBaseOfCloud:',cloudBaseHeight write (*, *) ' heightOfBaseOfCloud:', cloudBaseHeight
! Cloud type (low clouds) ! Cloud type (low clouds)
call codes_get(ibufr,'#1#cloudType',lowCloud) call codes_get(ibufr, '#1#cloudType', lowCloud)
write(*,*) ' cloudType (low):',lowCloud write (*, *) ' cloudType (low):', lowCloud
! Cloud type (middle clouds) ! Cloud type (middle clouds)
call codes_get(ibufr,'#2#cloudType',midCloud) call codes_get(ibufr, '#2#cloudType', midCloud)
write(*,*) ' cloudType (middle):',midCloud write (*, *) ' cloudType (middle):', midCloud
! Cloud type (high clouds) ! Cloud type (high clouds)
call codes_get(ibufr,'#3#cloudType',highCloud) call codes_get(ibufr, '#3#cloudType', highCloud)
write(*,*) ' cloudType (high):',highCloud write (*, *) ' cloudType (high):', highCloud
! Release the bufr message ! Release the bufr message
call codes_release(ibufr) call codes_release(ibufr)
! Load the next bufr message ! 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 end do
! Close file ! Close file
call codes_close_file(ifile) call codes_close_file(ifile)
end program bufr_read_synop 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. ! example. It is advised to use bufr_dump first to understand the structure of these messages.
! !
program bufr_read_temp program bufr_read_temp
use eccodes use eccodes
implicit none implicit none
integer :: ifile integer :: ifile
integer :: iret integer :: iret
integer :: ibufr integer :: ibufr
integer :: i, count=0 integer :: i, count = 0
integer(kind=4),dimension(:), allocatable :: timePeriod,extendedVerticalSoundingSignificance integer(kind=4), dimension(:), allocatable :: timePeriod, extendedVerticalSoundingSignificance
integer(kind=4) :: blockNumber,stationNumber integer(kind=4) :: blockNumber, stationNumber
real(kind=8),dimension(:), allocatable :: pressure,airTemperature,dewpointTemperature real(kind=8), dimension(:), allocatable :: pressure, airTemperature, dewpointTemperature
real(kind=8),dimension(:), allocatable :: geopotentialHeight,latitudeDisplacement,longitudeDisplacement real(kind=8), dimension(:), allocatable :: geopotentialHeight, latitudeDisplacement, longitudeDisplacement
real(kind=8),dimension(:), allocatable :: windDirection,windSpeed 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, ! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls ! 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(*,*) 'message: ',count write (*, *) 'message: ', count
call codes_set(ibufr,'unpack',1) call codes_set(ibufr, 'unpack', 1)
call codes_get(ibufr,'timePeriod',timePeriod) call codes_get(ibufr, 'timePeriod', timePeriod)
call codes_get(ibufr,'pressure',pressure) call codes_get(ibufr, 'pressure', pressure)
call codes_get(ibufr,'extendedVerticalSoundingSignificance',extendedVerticalSoundingSignificance) call codes_get(ibufr, 'extendedVerticalSoundingSignificance', extendedVerticalSoundingSignificance)
call codes_get(ibufr,'nonCoordinateGeopotentialHeight',geopotentialHeight) call codes_get(ibufr, 'nonCoordinateGeopotentialHeight', geopotentialHeight)
call codes_get(ibufr,'latitudeDisplacement',latitudeDisplacement) call codes_get(ibufr, 'latitudeDisplacement', latitudeDisplacement)
call codes_get(ibufr,'longitudeDisplacement',longitudeDisplacement) call codes_get(ibufr, 'longitudeDisplacement', longitudeDisplacement)
call codes_get(ibufr,'airTemperature',airTemperature) call codes_get(ibufr, 'airTemperature', airTemperature)
call codes_get(ibufr,'dewpointTemperature',dewpointTemperature) call codes_get(ibufr, 'dewpointTemperature', dewpointTemperature)
call codes_get(ibufr,'windDirection',windDirection) call codes_get(ibufr, 'windDirection', windDirection)
call codes_get(ibufr,'windSpeed',windSpeed) call codes_get(ibufr, 'windSpeed', windSpeed)
call codes_get(ibufr,'blockNumber',blockNumber) call codes_get(ibufr, 'blockNumber', blockNumber)
call codes_get(ibufr,'stationNumber',stationNumber) call codes_get(ibufr, 'stationNumber', stationNumber)
print *,'station',blockNumber,stationNumber print *, 'station', blockNumber, stationNumber
print *,'timePeriod pressure geopotentialHeight latitudeDisplacement & print *, 'timePeriod pressure geopotentialHeight latitudeDisplacement &
&longitudeDisplacement airTemperature windDirection windSpeed significance' &longitudeDisplacement airTemperature windDirection windSpeed significance'
do i=1,size(windSpeed) 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),& 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),& &geopotentialHeight(i), latitudeDisplacement(i),&
&longitudeDisplacement(i),airTemperature(i),windDirection(i),windSpeed(i),extendedVerticalSoundingSignificance(i) &longitudeDisplacement(i), airTemperature(i), windDirection(i), windSpeed(i), extendedVerticalSoundingSignificance(i)
enddo end do
! Free arrays ! Free arrays
deallocate(timePeriod) deallocate (timePeriod)
deallocate(pressure) deallocate (pressure)
deallocate(geopotentialHeight) deallocate (geopotentialHeight)
deallocate(latitudeDisplacement) deallocate (latitudeDisplacement)
deallocate(longitudeDisplacement) deallocate (longitudeDisplacement)
deallocate(airTemperature) deallocate (airTemperature)
deallocate(dewpointTemperature) deallocate (dewpointTemperature)
deallocate(windDirection) deallocate (windDirection)
deallocate(windSpeed) deallocate (windSpeed)
deallocate(extendedVerticalSoundingSignificance) deallocate (extendedVerticalSoundingSignificance)
! Release the bufr message ! Release the bufr message
call codes_release(ibufr) call codes_release(ibufr)
! Load the next bufr message ! 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 end do
! Close file ! Close file
call codes_close_file(ifile) call codes_close_file(ifile)
end program bufr_read_temp 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. ! example. It is advised to use bufr_dump first to understand the structure of these messages.
! !
program bufr_read_temp program bufr_read_temp
use eccodes use eccodes
implicit none implicit none
integer :: ifile integer :: ifile
integer :: iret integer :: iret
integer :: ibufr integer :: ibufr
integer :: i, count=0 integer :: i, count = 0
integer :: iflag integer :: iflag
integer :: status_id, status_ht, status_time=0, status_p integer :: status_id, status_ht, status_time = 0, status_p
integer :: status_rsno, status_rssoft, statid_missing integer :: status_rsno, status_rssoft, statid_missing
integer(kind=4) :: sizews integer(kind=4) :: sizews
integer(kind=4) :: blockNumber,stationNumber integer(kind=4) :: blockNumber, stationNumber
integer(kind=4) :: ymd,hms integer(kind=4) :: ymd, hms
logical :: llstdonly = .True. ! Set True to list standard levels only logical :: llstdonly = .True. ! Set True to list standard levels only
logical :: llskip logical :: llskip
real(kind=8) :: year,month,day,hour,minute,second real(kind=8) :: year, month, day, hour, minute, second
real(kind=8) :: htg,htp,htec=0,sondeType real(kind=8) :: htg, htp, htec = 0, sondeType
real(kind=8), dimension(:), allocatable :: lat,lon real(kind=8), dimension(:), allocatable :: lat, lon
real(kind=8), dimension(:), allocatable :: timeVal,dlatVal,dlonVal,vssVal real(kind=8), dimension(:), allocatable :: timeVal, dlatVal, dlonVal, vssVal
real(kind=8), dimension(:), allocatable :: presVal,zVal,tVal,tdVal,wdirVal,wspVal real(kind=8), dimension(:), allocatable :: presVal, zVal, tVal, tdVal, wdirVal, wspVal
character(len=128) :: statid character(len=128) :: statid
character(len=16) :: rsnumber character(len=16) :: rsnumber
character(len=16) :: rssoftware character(len=16) :: rssoftware
character(len=8) :: Note 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 ! the first bufr message is loaded from file
! ibufr is the bufr id to be used in subsequent calls ! 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)
do while (iret/=CODES_END_OF_FILE .AND. status_time==CODES_SUCCESS) do while (iret /= CODES_END_OF_FILE .AND. status_time == CODES_SUCCESS)
! we need to instruct ecCodes to expand all the descriptors ! we need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values ! i.e. unpack the data values
call codes_set(ibufr,"unpack",1); 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 count = count + 1
! geopotential, airTemperature, dewpointTemperature, llskip = .False.
! windDirection, windSpeed and pressure.
!
count=count+1 ! Metadata:
llskip=.False. 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: ! Ascent (skip incomplete reports for now)
call codes_get(ibufr,'shipOrMobileLandStationIdentifier',statid,status_id) call codes_get(ibufr, 'timePeriod', timeVal, status_time)
IF (status_id /= CODES_SUCCESS) statid = "UNKNOWN" IF (status_time /= CODES_SUCCESS) THEN
call codes_is_missing(ibufr,'shipOrMobileLandStationIdentifier',statid_missing) write (*, '(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ', count, &
IF (statid_missing == 1) statid = "MISSING" ' ', blockNumber, ' ', stationNumber, ymd, hms, lat(1), lon(1), htg, htp, INT(sondeType)
call codes_get(ibufr,'blockNumber',blockNumber) write (*, '(A)') 'Missing times - skip'
call codes_get(ibufr,'stationNumber',stationNumber) llskip = .True.
call codes_get(ibufr,'year',year) END IF
call codes_get(ibufr,'month',month) call codes_get(ibufr, 'pressure', presVal, status_p)
call codes_get(ibufr,'day',day) IF (status_p /= CODES_SUCCESS) THEN
call codes_get(ibufr,'hour',hour) write (*, '(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ', count, &
call codes_get(ibufr,'minute',minute) ' ', blockNumber, ' ', stationNumber, ymd, hms, lat(1), lon(1), htg, htp, INT(sondeType)
call codes_get(ibufr,'second',second,status_time) write (*, '(A)') 'Missing pressures - skip'
IF (status_time /= CODES_SUCCESS) second = 0.0 llskip = .True.
call codes_get(ibufr,'latitude',lat) END IF
call codes_get(ibufr,'longitude',lon) call codes_get(ibufr, 'nonCoordinateGeopotentialHeight', zVal, status_ht)
call codes_get(ibufr,'heightOfStationGroundAboveMeanSeaLevel',htg,status_ht) IF (status_ht /= CODES_SUCCESS) THEN
IF (status_ht /= CODES_SUCCESS) htg = -999.0 write (*, '(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ', count, &
call codes_get(ibufr,'heightOfBarometerAboveMeanSeaLevel',htp,status_ht) ' ', blockNumber, ' ', stationNumber, ymd, hms, lat(1), lon(1), htg, htp, INT(sondeType)
IF (status_ht /= CODES_SUCCESS) htp = -999.0 write (*, '(A)') 'Missing heights - skip'
call codes_get(ibufr,'radiosondeType',sondeType) llskip = .True.
call codes_get(ibufr,'heightOfStation',htec,status_ht) ! Height from WMO list (BUFR) END IF
IF (status_ht == CODES_SUCCESS .AND. htg == -999.0) htg = htec ! IF (blockNumber /= 17 .OR. stationNumber /= 196) llskip=.True. ! FIX
ymd = INT(year)*10000+INT(month)*100+INT(day) ! IF (blockNumber /= 17.0) llskip=.True. ! FIX
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) IF (.NOT. llskip) THEN
call codes_get(ibufr,'timePeriod',timeVal,status_time) call codes_get(ibufr, 'latitudeDisplacement', dlatVal)
IF (status_time /= CODES_SUCCESS) THEN call codes_get(ibufr, 'longitudeDisplacement', dlonVal)
write(*,'(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ',count, & call codes_get(ibufr, 'extendedVerticalSoundingSignificance', vssVal)
' ',blockNumber,' ',stationNumber,ymd,hms,lat(1),lon(1),htg,htp,INT(sondeType) !call codes_get(ibufr,'geopotentialHeight',zVal)
write(*,'(A)') 'Missing times - skip' call codes_get(ibufr, 'airTemperature', tVal)
llskip=.True. call codes_get(ibufr, 'dewpointTemperature', tdVal)
ENDIF call codes_get(ibufr, 'windDirection', wdirVal)
call codes_get(ibufr,'pressure',presVal,status_p) call codes_get(ibufr, 'windSpeed', wspVal)
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 ! ---- Array sizes (pressure size can be larger - wind shear levels)
call codes_get(ibufr,'latitudeDisplacement',dlatVal) sizews = size(wspVal)
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) ! ---- Print the values --------------------------------
sizews = size(wspVal) 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 -------------------------------- ! free arrays
write(*,'(A,A72)') 'Statid: ',statid deallocate (dlatVal, dlonVal, vssVal)
write(*,'(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4,I5)') 'Ob: ',count, & deallocate (presVal, zVal, tVal, tdVal, wdirVal, wspVal)
' ',blockNumber,' ',stationNumber,ymd,hms,lat(1),lon(1),htg,htp,INT(sondeType),sizews END IF
IF (status_ht == CODES_SUCCESS) write(*,'(A,F9.3,F10.3,F7.1)') & IF (ALLOCATED(timeVal)) deallocate (timeVal)
'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 ! release the bufr message
deallocate(dlatVal,dlonVal,vssVal) call codes_release(ibufr)
deallocate(presVal,zVal,tVal,tdVal,wdirVal,wspVal)
END IF
IF (ALLOCATED(timeVal)) deallocate(timeVal)
! release the bufr message ! load the next bufr message
call codes_release(ibufr) call codes_bufr_new_from_file(ifile, ibufr, iret)
! load the next bufr message end do
call codes_bufr_new_from_file(ifile,ibufr,iret)
end do ! close file
call codes_close_file(ifile)
! close file
call codes_close_file(ifile)
end program bufr_read_temp 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 implicit none
integer :: ifile integer :: ifile
integer :: iret integer :: iret
integer :: ibufr,skipMember integer :: ibufr, skipMember
integer :: significance integer :: significance
integer :: year,month,day,hour,minute integer :: year, month, day, hour, minute
integer :: i,j,k,ierr,count=1 integer :: i, j, k, ierr, count = 1
integer :: rankPosition,rankSignificance,rankPressure,rankWind integer :: rankPosition, rankSignificance, rankPressure, rankWind
integer :: rankPeriod,numberOfPeriods integer :: rankPeriod, numberOfPeriods
real(kind=8) :: latitudeCentre,longitudeCentre real(kind=8) :: latitudeCentre, longitudeCentre
real(kind=8), dimension(:), allocatable :: latitudeMaxWind0,longitudeMaxWind0,windMaxWind0 real(kind=8), dimension(:), allocatable :: latitudeMaxWind0, longitudeMaxWind0, windMaxWind0
real(kind=8), dimension(:), allocatable :: latitudeAnalysis,longitudeAnalysis,pressureAnalysis real(kind=8), dimension(:), allocatable :: latitudeAnalysis, longitudeAnalysis, pressureAnalysis
real(kind=8), dimension(:,:), allocatable :: latitude,longitude,pressure real(kind=8), dimension(:, :), allocatable :: latitude, longitude, pressure
real(kind=8), dimension(:,:), allocatable :: latitudeWind,longitudeWind,wind real(kind=8), dimension(:, :), allocatable :: latitudeWind, longitudeWind, wind
integer(kind=4), dimension(:), allocatable :: memberNumber,period integer(kind=4), dimension(:), allocatable :: memberNumber, period
real(kind=8), dimension(:), allocatable :: values real(kind=8), dimension(:), allocatable :: values
integer(kind=4), dimension(:), allocatable :: ivalues integer(kind=4), dimension(:), allocatable :: ivalues
character(len=8) :: rankSignificanceStr,rankPositionStr,rankPressureStr,rankWindStr character(len=8) :: rankSignificanceStr, rankPositionStr, rankPressureStr, rankWindStr
character(len=8) :: stormIdentifier,rankPeriodStr 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. ! The first BUFR message is loaded from file.
! ibufr is the BUFR id to be used in subsequent calls ! 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 ! 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, 'stormIdentifier', stormIdentifier)
call codes_get(ibufr,'month',month); write (*, '(A,A)') 'Storm identifier: ', stormIdentifier
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
! How many different timePeriod in the data structure? ! How many different timePeriod in the data structure?
rankPeriod=0 rankPeriod = 0
ierr=0 ierr = 0
do while(ierr==0) do while (ierr == 0)
rankPeriod=rankPeriod+1 rankPeriod = rankPeriod + 1
write (rankPeriodStr,'(I0)')rankPeriod write (rankPeriodStr, '(I0)') rankPeriod
call codes_get(ibufr,'#'//trim(rankPeriodStr)//'#timePeriod',period,ierr) call codes_get(ibufr, '#'//trim(rankPeriodStr)//'#timePeriod', period, ierr)
if(allocated(period)) deallocate(period) if (allocated(period)) deallocate (period)
enddo end do
! The numberOfPeriods includes the analysis (period=0) ! 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 (latitude(size(memberNumber), numberOfPeriods))
allocate(longitude(size(memberNumber),numberOfPeriods)) allocate (longitude(size(memberNumber), numberOfPeriods))
allocate(pressure(size(memberNumber),numberOfPeriods)) allocate (pressure(size(memberNumber), numberOfPeriods))
allocate(latitudeWind(size(memberNumber),numberOfPeriods)) allocate (latitudeWind(size(memberNumber), numberOfPeriods))
allocate(longitudeWind(size(memberNumber),numberOfPeriods)) allocate (longitudeWind(size(memberNumber), numberOfPeriods))
allocate(wind(size(memberNumber),numberOfPeriods)) allocate (wind(size(memberNumber), numberOfPeriods))
allocate(values(size(memberNumber))) allocate (values(size(memberNumber)))
allocate(period(numberOfPeriods)) allocate (period(numberOfPeriods))
period(1)=0 period(1) = 0
! Observed Storm Centre ! Observed Storm Centre
call codes_get(ibufr,'#1#meteorologicalAttributeSignificance',significance); call codes_get(ibufr, '#1#meteorologicalAttributeSignificance', significance);
call codes_get(ibufr,'#1#latitude',latitudeCentre); call codes_get(ibufr, '#1#latitude', latitudeCentre);
call codes_get(ibufr,'#1#longitude',longitudeCentre); call codes_get(ibufr, '#1#longitude', longitudeCentre);
if (significance/=1) then if (significance /= 1) then
print *,'ERROR: unexpected #1#meteorologicalAttributeSignificance' print *, 'ERROR: unexpected #1#meteorologicalAttributeSignificance'
stop 1 stop 1
endif end if
if (latitudeCentre==CODES_MISSING_DOUBLE .and. longitudeCentre==CODES_MISSING_DOUBLE) then if (latitudeCentre == CODES_MISSING_DOUBLE .and. longitudeCentre == CODES_MISSING_DOUBLE) then
write(*,'(a)')'Observed storm centre position missing' write (*, '(a)') 'Observed storm centre position missing'
else else
write(*,'(A,F8.2,A,F8.2)')'Observed storm centre: latitude=',latitudeCentre,' longitude=',longitudeCentre write (*, '(A,F8.2,A,F8.2)') 'Observed storm centre: latitude=', latitudeCentre, ' longitude=', longitudeCentre
endif end if
! Location of storm in perturbed analysis ! Location of storm in perturbed analysis
call codes_get(ibufr,'#2#meteorologicalAttributeSignificance',significance); call codes_get(ibufr, '#2#meteorologicalAttributeSignificance', significance);
call codes_get(ibufr,'#2#latitude',latitudeAnalysis); call codes_get(ibufr, '#2#latitude', latitudeAnalysis);
call codes_get(ibufr,'#2#longitude',longitudeAnalysis); call codes_get(ibufr, '#2#longitude', longitudeAnalysis);
call codes_get(ibufr,'#1#pressureReducedToMeanSeaLevel',pressureAnalysis); call codes_get(ibufr, '#1#pressureReducedToMeanSeaLevel', pressureAnalysis);
if (significance/=4) then if (significance /= 4) then
print *,'ERROR: unexpected #2#meteorologicalAttributeSignificance' print *, 'ERROR: unexpected #2#meteorologicalAttributeSignificance'
stop 1 stop 1
endif end if
if (size(latitudeAnalysis)==size(memberNumber)) then if (size(latitudeAnalysis) == size(memberNumber)) then
latitude(:,1)=latitudeAnalysis latitude(:, 1) = latitudeAnalysis
longitude(:,1)=longitudeAnalysis longitude(:, 1) = longitudeAnalysis
pressure(:,1)=pressureAnalysis pressure(:, 1) = pressureAnalysis
else else
latitude(:,1)=latitudeAnalysis(1) latitude(:, 1) = latitudeAnalysis(1)
longitude(:,1)=longitudeAnalysis(1) longitude(:, 1) = longitudeAnalysis(1)
pressure(:,1)=pressureAnalysis(1) pressure(:, 1) = pressureAnalysis(1)
endif end if
! Location of Maximum Wind ! Location of Maximum Wind
call codes_get(ibufr,'#3#meteorologicalAttributeSignificance',significance); call codes_get(ibufr, '#3#meteorologicalAttributeSignificance', significance);
call codes_get(ibufr,'#3#latitude',latitudeMaxWind0); call codes_get(ibufr, '#3#latitude', latitudeMaxWind0);
call codes_get(ibufr,'#3#longitude',longitudeMaxWind0); call codes_get(ibufr, '#3#longitude', longitudeMaxWind0);
if (significance/=3) then if (significance /= 3) then
print *,'ERROR: unexpected #3#meteorologicalAttributeSignificance=',significance print *, 'ERROR: unexpected #3#meteorologicalAttributeSignificance=', significance
stop 1 stop 1
endif end if
call codes_get(ibufr,'#1#windSpeedAt10M',windMaxWind0); call codes_get(ibufr, '#1#windSpeedAt10M', windMaxWind0);
if (size(latitudeMaxWind0)==size(memberNumber)) then if (size(latitudeMaxWind0) == size(memberNumber)) then
latitudeWind(:,1)=latitudeMaxWind0 latitudeWind(:, 1) = latitudeMaxWind0
longitudeWind(:,1)=longitudeMaxWind0 longitudeWind(:, 1) = longitudeMaxWind0
wind(:,1)=windMaxWind0 wind(:, 1) = windMaxWind0
else else
latitudeWind(:,1)=latitudeMaxWind0(1) latitudeWind(:, 1) = latitudeMaxWind0(1)
longitudeWind(:,1)=longitudeMaxWind0(1) longitudeWind(:, 1) = longitudeMaxWind0(1)
wind(:,1)=windMaxWind0(1) wind(:, 1) = windMaxWind0(1)
endif end if
rankSignificance=3 rankSignificance = 3
rankPosition=3 rankPosition = 3
rankPressure=1 rankPressure = 1
rankWind=1 rankWind = 1
rankPeriod=0 rankPeriod = 0
! Loop on all periods excluding analysis period(1)=0 ! Loop on all periods excluding analysis period(1)=0
do i=2,numberOfPeriods do i = 2, numberOfPeriods
rankPeriod=rankPeriod+1 rankPeriod = rankPeriod + 1
write (rankPeriodStr,'(I0)')rankPeriod write (rankPeriodStr, '(I0)') rankPeriod
call codes_get(ibufr,'#'//trim(rankPeriodStr)//'#timePeriod',ivalues); call codes_get(ibufr, '#'//trim(rankPeriodStr)//'#timePeriod', ivalues);
do k=1,size(ivalues) do k = 1, size(ivalues)
if (ivalues(k)/=CODES_MISSING_LONG) then if (ivalues(k) /= CODES_MISSING_LONG) then
period(i)=ivalues(k) period(i) = ivalues(k)
exit exit
endif end if
enddo end do
deallocate(ivalues) deallocate (ivalues)
! Location of the storm ! Location of the storm
rankSignificance=rankSignificance+1 rankSignificance = rankSignificance + 1
write (rankSignificanceStr,'(I0)')rankSignificance write (rankSignificanceStr, '(I0)') rankSignificance
call codes_get(ibufr,'#'//trim(rankSignificanceStr)//'#meteorologicalAttributeSignificance',ivalues); call codes_get(ibufr, '#'//trim(rankSignificanceStr)//'#meteorologicalAttributeSignificance', ivalues);
do k=1,size(ivalues) do k = 1, size(ivalues)
if (ivalues(k)/=CODES_MISSING_LONG) then if (ivalues(k) /= CODES_MISSING_LONG) then
significance=ivalues(k) significance = ivalues(k)
exit exit
endif end if
enddo end do
deallocate(ivalues) deallocate (ivalues)
rankPosition=rankPosition+1 rankPosition = rankPosition + 1
write (rankPositionStr,'(I0)')rankPosition write (rankPositionStr, '(I0)') rankPosition
call codes_get(ibufr,'#'//trim(rankPositionStr)//'#latitude',values); call codes_get(ibufr, '#'//trim(rankPositionStr)//'#latitude', values);
latitude(:,i)=values latitude(:, i) = values
call codes_get(ibufr,'#'//trim(rankPositionStr)//'#longitude',values); call codes_get(ibufr, '#'//trim(rankPositionStr)//'#longitude', values);
longitude(:,i)=values longitude(:, i) = values
if (significance==1) then if (significance == 1) then
rankPressure=rankPressure+1 rankPressure = rankPressure + 1
write (rankPressureStr,'(I0)')rankPressure write (rankPressureStr, '(I0)') rankPressure
call codes_get(ibufr,'#'//trim(rankPressureStr)//'#pressureReducedToMeanSeaLevel',values); call codes_get(ibufr, '#'//trim(rankPressureStr)//'#pressureReducedToMeanSeaLevel', values);
pressure(:,i)=values pressure(:, i) = values
else else
print *,'ERROR: unexpected meteorologicalAttributeSignificance=',significance print *, 'ERROR: unexpected meteorologicalAttributeSignificance=', significance
stop 1 stop 1
endif end if
! Location of maximum wind ! Location of maximum wind
rankSignificance=rankSignificance+1 rankSignificance = rankSignificance + 1
write (rankSignificanceStr,'(I0)')rankSignificance write (rankSignificanceStr, '(I0)') rankSignificance
call codes_get(ibufr,'#'//trim(rankSignificanceStr)//'#meteorologicalAttributeSignificance',ivalues); call codes_get(ibufr, '#'//trim(rankSignificanceStr)//'#meteorologicalAttributeSignificance', ivalues);
do k=1,size(ivalues) do k = 1, size(ivalues)
if (ivalues(k)/=CODES_MISSING_LONG) then if (ivalues(k) /= CODES_MISSING_LONG) then
significance=ivalues(k) significance = ivalues(k)
exit exit
endif end if
enddo end do
deallocate(ivalues) deallocate (ivalues)
rankPosition=rankPosition+1 rankPosition = rankPosition + 1
write (rankPositionStr,'(I0)')rankPosition write (rankPositionStr, '(I0)') rankPosition
call codes_get(ibufr,'#'//trim(rankPositionStr)//'#latitude',values); call codes_get(ibufr, '#'//trim(rankPositionStr)//'#latitude', values);
latitudeWind(:,i)=values latitudeWind(:, i) = values
call codes_get(ibufr,'#'//trim(rankPositionStr)//'#longitude',values); call codes_get(ibufr, '#'//trim(rankPositionStr)//'#longitude', values);
longitudeWind(:,i)=values longitudeWind(:, i) = values
if (significance==3) then if (significance == 3) then
rankWind=rankWind+1 rankWind = rankWind + 1
write (rankWindStr,'(I0)')rankWind write (rankWindStr, '(I0)') rankWind
call codes_get(ibufr,'#'//trim(rankWindStr)//'#windSpeedAt10M',values); call codes_get(ibufr, '#'//trim(rankWindStr)//'#windSpeedAt10M', values);
wind(:,i)=values wind(:, i) = values
else else
print *,'ERROR: unexpected meteorologicalAttributeSignificance=,',significance print *, 'ERROR: unexpected meteorologicalAttributeSignificance=,', significance
stop 1 stop 1
endif end if
enddo end do
! Print the values ! Print the values
do i=1,size(memberNumber) do i = 1, size(memberNumber)
skipMember=1 skipMember = 1
do j=1,size(period) do j = 1, size(period)
if (latitude(i,j)/=CODES_MISSING_DOUBLE .OR. latitudeWind(i,j)/=CODES_MISSING_DOUBLE) then if (latitude(i, j) /= CODES_MISSING_DOUBLE .OR. latitudeWind(i, j) /= CODES_MISSING_DOUBLE) then
skipMember=0 skipMember = 0
exit exit
endif end if
enddo end do
if (skipMember/=1) then if (skipMember /= 1) then
write(*,'(A,I3)') '== Member ',memberNumber(i) write (*, '(A,I3)') '== Member ', memberNumber(i)
write(*,*) 'step latitude longitude pressure latitude longitude wind' write (*, *) 'step latitude longitude pressure latitude longitude wind'
do j=1,size(period) do j = 1, size(period)
if (latitude(i,j)/=CODES_MISSING_DOUBLE .OR. latitudeWind(i,j)/=CODES_MISSING_DOUBLE) then 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),& write (*, '( I4,2X,F8.2,4X,F8.2,3X,F9.1,2X,F8.2,4X,F8.2,2X,F8.2)') &
&latitudeWind(i,j),longitudeWind(i,j),wind(i,j) period(j), latitude(i, j), longitude(i, j), pressure(i, j), &
endif latitudeWind(i, j), longitudeWind(i, j), wind(i, j)
enddo end if
end do
endif end if
enddo end do
! deallocating the arrays is very important ! deallocating the arrays is very important
! because the behaviour of the codes_get functions is as follows: ! because the behaviour of the codes_get functions is as follows:
! if the array is not allocated then allocate ! if the array is not allocated then allocate
! if the array is already allocated only copy the values ! if the array is already allocated only copy the values
deallocate(values) deallocate (values)
deallocate(latitude) deallocate (latitude)
deallocate(longitude) deallocate (longitude)
deallocate(pressure) deallocate (pressure)
deallocate(latitudeWind) deallocate (latitudeWind)
deallocate(longitudeWind) deallocate (longitudeWind)
deallocate(wind) deallocate (wind)
deallocate(period) deallocate (period)
deallocate(latitudeAnalysis) deallocate (latitudeAnalysis)
deallocate(longitudeAnalysis) deallocate (longitudeAnalysis)
deallocate(pressureAnalysis) deallocate (pressureAnalysis)
deallocate(memberNumber) deallocate (memberNumber)
deallocate(latitudeMaxWind0) deallocate (latitudeMaxWind0)
deallocate(longitudeMaxWind0) deallocate (longitudeMaxWind0)
deallocate(windMaxWind0) deallocate (windMaxWind0)
! Release the BUFR message ! Release the BUFR message
call codes_release(ibufr) call codes_release(ibufr)
! Load the next BUFR message ! 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 end do

72
examples/F90/bufr_set_keys.f90
View File

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

87
examples/F90/bufr_subset.f90
View File

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

166
examples/F90/get_fortran.f90
View File

@ -10,108 +10,108 @@
! !
! !
program get program get
use eccodes use eccodes
implicit none implicit none
integer :: ifile integer :: ifile
integer :: iret integer :: iret
integer :: igrib integer :: igrib
integer :: i integer :: i
real(kind=8) :: latitudeOfFirstPointInDegrees real(kind=8) :: latitudeOfFirstPointInDegrees
real(kind=8) :: longitudeOfFirstPointInDegrees real(kind=8) :: longitudeOfFirstPointInDegrees
real(kind=8) :: latitudeOfLastPointInDegrees real(kind=8) :: latitudeOfLastPointInDegrees
real(kind=8) :: longitudeOfLastPointInDegrees real(kind=8) :: longitudeOfLastPointInDegrees
real(kind=8) :: jDirectionIncrementInDegrees real(kind=8) :: jDirectionIncrementInDegrees
real(kind=8) :: iDirectionIncrementInDegrees real(kind=8) :: iDirectionIncrementInDegrees
integer(kind = 4) :: numberOfPointsAlongAParallel integer(kind=4) :: numberOfPointsAlongAParallel
integer(kind = 4) :: numberOfPointsAlongAMeridian integer(kind=4) :: numberOfPointsAlongAMeridian
real(kind=8), dimension(:), allocatable :: values real(kind=8), dimension(:), allocatable :: values
integer(kind = 4) :: numberOfValues integer(kind=4) :: numberOfValues
real(kind=8) :: average real(kind=8) :: average
call codes_open_file(ifile, & call codes_open_file(ifile, &
'../../data/reduced_latlon_surface.grib1','r') '../../data/reduced_latlon_surface.grib1', 'r')
! A new grib message is loaded from file ! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls ! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(ifile,igrib) call codes_grib_new_from_file(ifile, igrib)
! get as a integer ! get as a integer
call codes_get(igrib,'numberOfPointsAlongAParallel', & call codes_get(igrib, 'numberOfPointsAlongAParallel', &
numberOfPointsAlongAParallel) numberOfPointsAlongAParallel)
write(*,*) 'numberOfPointsAlongAParallel=', & write (*, *) 'numberOfPointsAlongAParallel=', &
numberOfPointsAlongAParallel numberOfPointsAlongAParallel
! get as a integer ! get as a integer
call codes_get(igrib,'numberOfPointsAlongAMeridian', & call codes_get(igrib, 'numberOfPointsAlongAMeridian', &
numberOfPointsAlongAMeridian) numberOfPointsAlongAMeridian)
write(*,*) 'numberOfPointsAlongAMeridian=', & write (*, *) 'numberOfPointsAlongAMeridian=', &
numberOfPointsAlongAMeridian numberOfPointsAlongAMeridian
! get as a real8 ! get as a real8
call codes_get(igrib, & call codes_get(igrib, &
'latitudeOfFirstGridPointInDegrees', & 'latitudeOfFirstGridPointInDegrees', &
latitudeOfFirstPointInDegrees) latitudeOfFirstPointInDegrees)
write(*,*) 'latitudeOfFirstGridPointInDegrees=', & write (*, *) 'latitudeOfFirstGridPointInDegrees=', &
latitudeOfFirstPointInDegrees latitudeOfFirstPointInDegrees
! get as a real8 ! get as a real8
call codes_get(igrib, & call codes_get(igrib, &
'longitudeOfFirstGridPointInDegrees', & 'longitudeOfFirstGridPointInDegrees', &
longitudeOfFirstPointInDegrees) longitudeOfFirstPointInDegrees)
write(*,*) 'longitudeOfFirstGridPointInDegrees=', & write (*, *) 'longitudeOfFirstGridPointInDegrees=', &
longitudeOfFirstPointInDegrees longitudeOfFirstPointInDegrees
! get as a real8 ! get as a real8
call codes_get(igrib, & call codes_get(igrib, &
'latitudeOfLastGridPointInDegrees', & 'latitudeOfLastGridPointInDegrees', &
latitudeOfLastPointInDegrees) latitudeOfLastPointInDegrees)
write(*,*) 'latitudeOfLastGridPointInDegrees=', & write (*, *) 'latitudeOfLastGridPointInDegrees=', &
latitudeOfLastPointInDegrees latitudeOfLastPointInDegrees
! get as a real8 ! get as a real8
call codes_get(igrib, & call codes_get(igrib, &
'longitudeOfLastGridPointInDegrees', & 'longitudeOfLastGridPointInDegrees', &
longitudeOfLastPointInDegrees) longitudeOfLastPointInDegrees)
write(*,*) 'longitudeOfLastGridPointInDegrees=', & write (*, *) 'longitudeOfLastGridPointInDegrees=', &
longitudeOfLastPointInDegrees longitudeOfLastPointInDegrees
! get as a real8 ! get as a real8
call codes_get(igrib, & call codes_get(igrib, &
'jDirectionIncrementInDegrees', & 'jDirectionIncrementInDegrees', &
jDirectionIncrementInDegrees) jDirectionIncrementInDegrees)
write(*,*) 'jDirectionIncrementInDegrees=', & write (*, *) 'jDirectionIncrementInDegrees=', &
jDirectionIncrementInDegrees jDirectionIncrementInDegrees
! get as a real8 ! get as a real8
call codes_get(igrib, & call codes_get(igrib, &
'iDirectionIncrementInDegrees', & 'iDirectionIncrementInDegrees', &
iDirectionIncrementInDegrees) iDirectionIncrementInDegrees)
write(*,*) 'iDirectionIncrementInDegrees=', & write (*, *) 'iDirectionIncrementInDegrees=', &
iDirectionIncrementInDegrees iDirectionIncrementInDegrees
! get the size of the values array ! get the size of the values array
call codes_get_size(igrib,'values',numberOfValues) call codes_get_size(igrib, 'values', numberOfValues)
write(*,*) 'numberOfValues=',numberOfValues write (*, *) 'numberOfValues=', numberOfValues
allocate(values(2*numberOfValues), stat=iret) allocate (values(2*numberOfValues), stat=iret)
! get data values ! get data values
print*, size(values) print *, size(values)
call codes_get(igrib,'values',values) call codes_get(igrib, 'values', values)
average = 0 average = 0
do i=1,numberOfValues do i = 1, numberOfValues
average = average + values(i); average = average + values(i);
enddo end do
average =average / numberOfValues average = average/numberOfValues
write(*,*)'There are ',numberOfValues, & write (*, *) 'There are ', numberOfValues, &
' average is ',average ' 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 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) ! and print the kind of product (e.g. GRIB, BUFR etc)
! !
program get_product_kind program get_product_kind
use eccodes use eccodes
implicit none implicit none
integer :: ifile integer :: ifile
integer :: iret integer :: iret
integer :: ihandle integer :: ihandle
integer :: count=0 integer :: count = 0
integer :: version=0 integer :: version = 0
character(len=32) :: product_kind character(len=32) :: product_kind
character(len=120) :: infile_name character(len=120) :: infile_name
call getarg(1, infile_name) call getarg(1, infile_name)
write(*,*) 'infile_name|',infile_name,'|' write (*, *) 'infile_name|', infile_name, '|'
call codes_open_file(ifile,infile_name,'r') call codes_open_file(ifile, infile_name, 'r')
call codes_get_api_version(version) call codes_get_api_version(version)
write(*,*) 'API version: ',version write (*, *) 'API version: ', version
write(*,*) 'ecCodes settings: ' write (*, *) 'ecCodes settings: '
write(*,*) ' ECCODES_POSIX_THREADS: ',ECCODES_SETTINGS_POSIX_THREADS write (*, *) ' ECCODES_POSIX_THREADS: ', ECCODES_SETTINGS_POSIX_THREADS
write(*,*) ' ECCODES_OMP_THREADS: ',ECCODES_SETTINGS_OMP_THREADS write (*, *) ' ECCODES_OMP_THREADS: ', ECCODES_SETTINGS_OMP_THREADS
write(*,*) ' ECCODES_SETTINGS_MEMFS: ',ECCODES_SETTINGS_MEMFS write (*, *) ' ECCODES_SETTINGS_MEMFS: ', ECCODES_SETTINGS_MEMFS
write(*,*) ' ECCODES_SETTINGS_JPEG: ',ECCODES_SETTINGS_JPEG write (*, *) ' ECCODES_SETTINGS_JPEG: ', ECCODES_SETTINGS_JPEG
write(*,*) ' ECCODES_SETTINGS_PNG: ',ECCODES_SETTINGS_PNG write (*, *) ' ECCODES_SETTINGS_PNG: ', ECCODES_SETTINGS_PNG
write(*,*) ' ECCODES_SETTINGS_AEC: ',ECCODES_SETTINGS_AEC write (*, *) ' ECCODES_SETTINGS_AEC: ', ECCODES_SETTINGS_AEC
! the first message is loaded from file ! the first message is loaded from file
! ihandle is the message id to be used in subsequent calls ! 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 ! get the product kind
call codes_get(ihandle,'kindOfProduct',product_kind) call codes_get(ihandle, 'kindOfProduct', product_kind)
write(*,*) ' product: ',product_kind write (*, *) ' product: ', product_kind
! release the message ! release the message
call codes_release(ihandle) call codes_release(ihandle)
! load the next message ! load the next message
call codes_new_from_file(ifile,ihandle,CODES_PRODUCT_ANY,iret) call codes_new_from_file(ifile, ihandle, CODES_PRODUCT_ANY, iret)
count=count+1 count = count + 1
end do end do
! close file ! close file
call codes_close_file(ifile) call codes_close_file(ifile)
end program get_product_kind end program get_product_kind

86
examples/F90/grib_clone.f90
View File

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

59
examples/F90/grib_copy_message.f90
View File

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

28
examples/F90/grib_copy_namespace.f90
View File

@ -11,26 +11,26 @@
! !
! !
program copy_namespace program copy_namespace
use eccodes use eccodes
implicit none implicit none
integer :: file1, file2, file3 integer :: file1, file2, file3
integer :: igrib1,igrib2,igrib3 integer :: igrib1, igrib2, igrib3
call codes_open_file(file1, '../../data/reduced_latlon_surface.grib2', 'r') 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(file2, '../../data/regular_latlon_surface.grib1', 'r')
call codes_open_file(file3, 'out.grib_copy_namespace.grib','w') 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(file1, igrib1)
call codes_grib_new_from_file(file2, igrib2) 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_write(igrib3, file3)
call codes_close_file(file1) call codes_close_file(file1)
call codes_close_file(file2) call codes_close_file(file2)
call codes_close_file(file3) call codes_close_file(file3)
end program copy_namespace end program copy_namespace

153
examples/F90/grib_count_messages.f90
View File

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

28
examples/F90/grib_count_messages_multi.f90
View File

@ -10,25 +10,25 @@
! !
! !
program grib_count_messages_multi program grib_count_messages_multi
use eccodes use eccodes
implicit none implicit none
integer :: ifile integer :: ifile
character(len=100) :: grib_file character(len=100) :: grib_file
integer :: n,stat integer :: n, stat
character(len=1) :: multi_flag character(len=1) :: multi_flag
call getarg(1,multi_flag) call getarg(1, multi_flag)
call getarg(2,grib_file) 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 ! count the messages in the file
call codes_count_in_file(ifile,n,stat) 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 end program grib_count_messages_multi

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

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

108
examples/F90/grib_get_data.f90
View File

@ -11,71 +11,71 @@
! !
! !
program get_data program get_data
use eccodes use eccodes
implicit none implicit none
integer :: ifile integer :: ifile
integer :: iret,i integer :: iret, i
real(kind=8),dimension(:),allocatable :: lats,lons,values real(kind=8), dimension(:), allocatable :: lats, lons, values
integer,dimension(:),allocatable :: bitmap integer, dimension(:), allocatable :: bitmap
integer(4) :: numberOfPoints integer(4) :: numberOfPoints
logical :: is_missing_value logical :: is_missing_value
integer :: count1=0, count2=0, bitmapPresent=0, bmp_len=0 integer :: count1 = 0, count2 = 0, bitmapPresent = 0, bmp_len = 0
! Message identifier. ! Message identifier.
integer :: igrib integer :: igrib
ifile=5 ifile = 5
call codes_open_file(ifile, & call codes_open_file(ifile, &
'../../data/reduced_latlon_surface.grib1','R') '../../data/reduced_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) call codes_grib_new_from_file(ifile, igrib, iret)
do while (iret/=CODES_END_OF_FILE) do while (iret /= CODES_END_OF_FILE)
count1=count1+1 count1 = count1 + 1
print *, "===== Message #",count1 print *, "===== Message #", count1
call codes_get(igrib,'numberOfPoints',numberOfPoints) call codes_get(igrib, 'numberOfPoints', numberOfPoints)
call codes_get(igrib,'bitmapPresent',bitmapPresent) call codes_get(igrib, 'bitmapPresent', bitmapPresent)
allocate(lats(numberOfPoints)) allocate (lats(numberOfPoints))
allocate(lons(numberOfPoints)) allocate (lons(numberOfPoints))
allocate(values(numberOfPoints)) allocate (values(numberOfPoints))
if (bitmapPresent == 1) then if (bitmapPresent == 1) then
! get the bitmap ! get the bitmap
call codes_get_size(igrib, 'bitmap', bmp_len) call codes_get_size(igrib, 'bitmap', bmp_len)
allocate(bitmap(bmp_len)) allocate (bitmap(bmp_len))
call codes_get(igrib,'bitmap', bitmap) 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.
end if end if
! Only print non-missing values
if (.not. is_missing_value) then call codes_grib_get_data(igrib, lats, lons, values)
print *, lats(i),lons(i),values(i)
count2=count2+1 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 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 (lats)
deallocate(lons) deallocate (lons)
deallocate(values) deallocate (values)
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 end do
call codes_close_file(ifile) call codes_close_file(ifile)
end program end program

150
examples/F90/grib_get_keys.f90
View File

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

52
examples/F90/grib_get_pl.f90
View File

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

52
examples/F90/grib_get_pv.f90
View File

@ -11,35 +11,35 @@
! !
! !
program grib_get_pv program grib_get_pv
use eccodes use eccodes
implicit none implicit none
integer :: infile integer :: infile
integer :: igrib integer :: igrib
integer :: PVPresent, nb_pv integer :: PVPresent, nb_pv
real, dimension(:), allocatable :: pv real, dimension(:), allocatable :: pv
call codes_open_file(infile, & call codes_open_file(infile, &
'../../data/reduced_gaussian_model_level.grib1','r') '../../data/reduced_gaussian_model_level.grib1', 'r')
! A new grib message is loaded from file ! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls ! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib) call codes_grib_new_from_file(infile, igrib)
! Get PVPresent to see if the 'pv' array is there ! Get PVPresent to see if the 'pv' array is there
call codes_get(igrib,'PVPresent',PVPresent) call codes_get(igrib, 'PVPresent', PVPresent)
print*, "PVPresent = ", PVPresent print *, "PVPresent = ", PVPresent
if (PVPresent == 1) then if (PVPresent == 1) then
call codes_get_size(igrib,'pv',nb_pv) call codes_get_size(igrib, 'pv', nb_pv)
print*, "There are ", nb_pv, " PV values" print *, "There are ", nb_pv, " PV values"
allocate(pv(nb_pv)) allocate (pv(nb_pv))
call codes_get(igrib,'pv',pv) call codes_get(igrib, 'pv', pv)
print*, "pv = ", pv print *, "pv = ", pv
deallocate(pv) deallocate (pv)
else else
print*, "There is no PV values in your GRIB message!" print *, "There is no PV values in your GRIB message!"
end if end if
call codes_release(igrib) call codes_release(igrib)
call codes_close_file(infile) call codes_close_file(infile)
end program grib_get_pv 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). ! Original authors: Harald Anlauf, Doerte Liermann (DWD), Luis Kornblueh (MPIfM).
! !
program grib_get_set_uuid program grib_get_set_uuid
use eccodes use eccodes
implicit none implicit none
integer :: infile, outfile integer :: infile, outfile
integer :: igrib, ogrib integer :: igrib, ogrib
integer :: count1, i, iret, nvg, ffs, length 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_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=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 ! Human-readable uuid.
character(len=32) :: uuid_string_expected ! Expected UUID of input 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 ! Load first grib message from file
! igrib is the grib id to be used in subsequent calls ! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file (infile, igrib, iret) call codes_grib_new_from_file(infile, igrib, iret)
uuid_string_expected = '08b1e836bc6911e1951fb51b5624ad8d' uuid_string_expected = '08b1e836bc6911e1951fb51b5624ad8d'
count1 = 0 count1 = 0
do while (iret/=CODES_END_OF_FILE) do while (iret /= CODES_END_OF_FILE)
count1 = count1 + 1 count1 = count1 + 1
print *, "### Record:", count1 print *, "### Record:", count1
call codes_get(igrib,'typeOfFirstFixedSurface',ffs) call codes_get(igrib, 'typeOfFirstFixedSurface', ffs)
print *, 'typeOfFirstFixedSurface =', ffs print *, 'typeOfFirstFixedSurface =', ffs
if (ffs /= 150) then if (ffs /= 150) then
print *, "Unexpected typeOfFirstFixedSurface (must be 150)." print *, "Unexpected typeOfFirstFixedSurface (must be 150)."
stop stop
end if end if
call codes_get (igrib,'numberOfVGridUsed',nvg) call codes_get(igrib, 'numberOfVGridUsed', nvg)
print *, 'numberOfVGridUsed =',nvg print *, 'numberOfVGridUsed =', nvg
! call codes_get (igrib,'uuidOfVGrid',uuid_in) ! Assuming length is ok. ! call codes_get (igrib,'uuidOfVGrid',uuid_in) ! Assuming length is ok.
call codes_get (igrib,'uuidOfVGrid',uuid_in,length=length) call codes_get(igrib, 'uuidOfVGrid', uuid_in, length=length)
if (length /= 16) then if (length /= 16) then
print *, "Sorry, bad length of byte_array:", length, ". Expected: 16" print *, "Sorry, bad length of byte_array:", length, ". Expected: 16"
stop stop
end if end if
! Convert byte array to hexadecimal string for printing ! Convert byte array to hexadecimal string for printing
do i = 1, size (uuid_in) do i = 1, size(uuid_in)
uuid_string(2*i-1:2*i) = byte2hex(uuid_in(i)) uuid_string(2*i - 1:2*i) = byte2hex(uuid_in(i))
end do end do
print *, "uuidOfVGrid (on input) = ", uuid_string print *, "uuidOfVGrid (on input) = ", uuid_string
if (uuid_string .ne. uuid_string_expected) then if (uuid_string .ne. uuid_string_expected) then
print *, "Sorry, bad value of byte_array. Expected: ", uuid_string_expected print *, "Sorry, bad value of byte_array. Expected: ", uuid_string_expected
stop stop
end if end if
call codes_clone (igrib,ogrib) call codes_clone(igrib, ogrib)
! On output we write a modified uuid (here the input is simply reversed) ! On output we write a modified uuid (here the input is simply reversed)
uuid_out(1:16) = uuid_in(16:1:-1) uuid_out(1:16) = uuid_in(16:1:-1)
call codes_set (ogrib,'uuidOfVGrid',uuid_out) call codes_set(ogrib, 'uuidOfVGrid', uuid_out)
call codes_write (ogrib,outfile) call codes_write(ogrib, outfile)
call codes_release (igrib) call codes_release(igrib)
call codes_release (ogrib) call codes_release(ogrib)
call codes_grib_new_from_file (infile, igrib, iret) call codes_grib_new_from_file(infile, igrib, iret)
end do end do
call codes_close_file (infile) call codes_close_file(infile)
call codes_close_file (outfile) call codes_close_file(outfile)
contains contains
! Convert single byte to 'hexadecimal' string ! Convert single byte to 'hexadecimal' string
pure function byte2hex (c) result (hex) pure function byte2hex(c) result(hex)
character(len=1), intent(in) :: c character(len=1), intent(in) :: c
character(len=2) :: hex character(len=2) :: hex
integer :: x integer :: x
x = iachar (c) x = iachar(c)
hex(1:1) = nibble ( x / 16) hex(1:1) = nibble(x/16)
hex(2:2) = nibble (iand (x, 15)) hex(2:2) = nibble(iand(x, 15))
end function byte2hex end function byte2hex
! Convert 'nibble' to 'hexadecimal' ! Convert 'nibble' to 'hexadecimal'
pure function nibble (x) pure function nibble(x)
integer, intent(in) :: x integer, intent(in) :: x
character :: nibble character :: nibble
select case (x) select case (x)
case (0:9) case (0:9)
nibble = achar (iachar ('0') + x) nibble = achar(iachar('0') + x)
case default case default
nibble = achar (iachar ('a') - 10 + x) nibble = achar(iachar('a') - 10 + x)
end select end select
end function nibble end function nibble
end program grib_get_set_uuid end program grib_get_set_uuid

168
examples/F90/grib_index.f90
View File

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

65
examples/F90/grib_keys_iterator.f90
View File

@ -14,50 +14,49 @@
! !
! !
program keys_iterator program keys_iterator
use eccodes use eccodes
implicit none implicit none
character(len=20) :: name_space character(len=20) :: name_space
integer :: kiter,ifile,igrib,iret integer :: kiter, ifile, igrib, iret
character(len=256) :: key character(len=256) :: key
character(len=256) :: value character(len=256) :: value
character(len=512) :: all1 character(len=512) :: all1
integer :: grib_count integer :: grib_count
call codes_open_file(ifile, & call codes_open_file(ifile, &
'../../data/regular_latlon_surface.grib1','r') '../../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) call codes_grib_new_from_file(ifile, igrib, iret)
grib_count=0 grib_count = 0
do while (iret /= CODES_END_OF_FILE) do while (iret /= CODES_END_OF_FILE)
grib_count=grib_count+1 grib_count = grib_count + 1
write(*,*) '-- GRIB N. ',grib_count,' --' write (*, *) '-- GRIB N. ', grib_count, ' --'
! valid name_spaces are ls and mars ! valid name_spaces are ls and mars
name_space='ls' name_space = 'ls'
call codes_keys_iterator_new(igrib,kiter,name_space) call codes_keys_iterator_new(igrib, kiter, name_space)
do do
call codes_keys_iterator_next(kiter, iret) 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_keys_iterator_get_name(kiter, key)
call codes_get(igrib,trim(key),value) call codes_get(igrib, trim(key), value)
all1=trim(key)// ' = ' // trim(value) all1 = trim(key)//' = '//trim(value)
write(*,*) trim(all1) write (*, *) trim(all1)
end do end do
call codes_keys_iterator_delete(kiter) call codes_keys_iterator_delete(kiter)
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 end do
call codes_close_file(ifile)
call codes_close_file(ifile)
end program keys_iterator 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. ! For all the tools default is multi support ON.
! !
program multi program multi
use eccodes use eccodes
implicit none implicit none
integer :: iret integer :: iret
integer(kind = 4) :: step integer(kind=4) :: step
integer :: ifile,igrib 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 */ ! turn on support for multi-field messages */
call codes_grib_multi_support_on() call codes_grib_multi_support_on()
! turn off support for multi-field messages */ ! turn off support for multi-field messages */
!call codes_grib_multi_support_off() !call codes_grib_multi_support_off()
call codes_grib_new_from_file(ifile,igrib, iret) call codes_grib_new_from_file(ifile, igrib, iret)
! Loop on all the messages in a file. ! Loop on all the messages in a file.
write(*,*) 'step' write (*, *) 'step'
do while (iret /= CODES_END_OF_FILE) do while (iret /= CODES_END_OF_FILE)
call codes_get(igrib,'step', step) call codes_get(igrib, 'step', step)
write(*,'(i3)') step write (*, '(i3)') step
call codes_grib_new_from_file(ifile,igrib, iret) 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 multi end program multi

44
examples/F90/grib_multi_write.f90
View File

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

108
examples/F90/grib_nearest.f90
View File

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

124
examples/F90/grib_precision.f90
View File

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

70
examples/F90/grib_print_data.f90
View File

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

64
examples/F90/grib_print_data_static.f90
View File

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

48
examples/F90/grib_read_message.f90
View File

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

114
examples/F90/grib_samples.f90
View File

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

94
examples/F90/grib_set_bitmap.f90
View File

@ -13,67 +13,67 @@
! !
! !
program set_bitmap program set_bitmap
use eccodes use eccodes
implicit none implicit none
integer :: infile,outfile integer :: infile, outfile
integer :: igrib, iret integer :: igrib, iret
integer :: numberOfValues integer :: numberOfValues
real, dimension(:), allocatable :: values real, dimension(:), allocatable :: values
real :: missingValue real :: missingValue
logical :: grib1Example logical :: grib1Example
grib1Example=.true. grib1Example = .true.
if (grib1Example) then if (grib1Example) then
! GRIB 1 example ! GRIB 1 example
call codes_open_file(infile,'../../data/regular_latlon_surface.grib1','r') call codes_open_file(infile, '../../data/regular_latlon_surface.grib1', 'r')
else else
! GRIB 2 example ! GRIB 2 example
call codes_open_file(infile,'../../data/regular_latlon_surface.grib2','r') call codes_open_file(infile, '../../data/regular_latlon_surface.grib2', 'r')
end if 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 ! A new grib message is loaded from file
! igrib is the grib id to be used in subsequent calls ! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib) call codes_grib_new_from_file(infile, igrib)
! The missingValue is not coded in the message. ! The missingValue is not coded in the message.
! It is a value we define as a placeholder for a missing value ! It is a value we define as a placeholder for a missing value
! at a point in the grid. ! at a point in the grid.
! It should be chosen so that it cannot be confused ! It should be chosen so that it cannot be confused
! with a valid field value ! with a valid field value
missingValue=9999 missingValue = 9999
call codes_set(igrib, 'missingValue',missingValue) call codes_set(igrib, 'missingValue', missingValue)
write(*,*) 'missingValue=',missingValue write (*, *) 'missingValue=', missingValue
! get the size of the values array ! get the size of the values array
call codes_get_size(igrib,'values',numberOfValues) call codes_get_size(igrib, 'values', numberOfValues)
write(*,*) 'numberOfValues=',numberOfValues write (*, *) 'numberOfValues=', numberOfValues
allocate(values(numberOfValues), stat=iret) allocate (values(numberOfValues), stat=iret)
! get data values ! get data values
call codes_get(igrib,'values',values) call codes_get(igrib, 'values', values)
! enable bitmap ! enable bitmap
call codes_set(igrib, 'bitmapPresent', 1) call codes_set(igrib, 'bitmapPresent', 1)
! set some values to be missing ! set some values to be missing
values(1:10) = missingValue values(1:10) = missingValue
! set the values (the bitmap will be automatically built) ! set the values (the bitmap will be automatically built)
call codes_set(igrib,'values', values) call codes_set(igrib, 'values', values)
! write modified message to a file ! write modified message to a file
call codes_write(igrib,outfile) call codes_write(igrib, outfile)
! free memory ! free memory
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(values) deallocate (values)
end program set_bitmap 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 ! If there are missing values, refer to: grib_set_bitmap
! !
program set_data program set_data
use eccodes use eccodes
implicit none implicit none
integer :: outfile integer :: outfile
integer :: i, igrib, iret, numberOfValues, cnt integer :: i, igrib, iret, numberOfValues, cnt
real :: d, e real :: d, e
real, dimension(:), allocatable :: values real, dimension(:), allocatable :: values
integer, parameter :: max_strsize = 200 integer, parameter :: max_strsize = 200
character(len=max_strsize) :: outfile_name character(len=max_strsize) :: outfile_name
call getarg(1, outfile_name) call getarg(1, outfile_name)
call codes_open_file(outfile,outfile_name,'w') call codes_open_file(outfile, outfile_name, 'w')
! Note: the full name of the sample file is "regular_ll_pl_grib1.tmpl" ! 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 ! Sample files are stored in the samples directory (use codes_info to
! see where that is). The default sample path can be changed by ! see where that is). The default sample path can be changed by
! setting the environment variable ECCODES_SAMPLES_PATH ! setting the environment variable ECCODES_SAMPLES_PATH
call codes_grib_new_from_samples(igrib, 'regular_ll_pl_grib1') call codes_grib_new_from_samples(igrib, 'regular_ll_pl_grib1')
! Here we're changing the data values only, so the number of values ! Here we're changing the data values only, so the number of values
! will be the same as the sample GRIB. ! will be the same as the sample GRIB.
! But if your data array has a different size, then specify the grid geometry ! 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 ! (e.g. keys Ni, Nj etc) and set the correct number of data values
call codes_get_size(igrib,'values',numberOfValues) call codes_get_size(igrib, 'values', numberOfValues)
allocate(values(numberOfValues), stat=iret) allocate (values(numberOfValues), stat=iret)
d = 10e-8 d = 10e-8
e = d e = d
cnt = 1 cnt = 1
do i=1,numberOfValues do i = 1, numberOfValues
if (cnt>100) then if (cnt > 100) then
e = e*10 e = e*10
cnt=1 cnt = 1
endif end if
values(i) = d values(i) = d
!print *, values(i) !print *, values(i)
d = d + e d = d + e
cnt = cnt + 1 cnt = cnt + 1
end do end do
call codes_set(igrib, 'bitsPerValue', 16) call codes_set(igrib, 'bitsPerValue', 16)
! set data values ! set data values
call codes_set(igrib,'values', values) call codes_set(igrib, 'values', values)
call codes_write(igrib,outfile) call codes_write(igrib, outfile)
call codes_release(igrib) call codes_release(igrib)
deallocate(values) deallocate (values)
end program set_data end program set_data

68
examples/F90/grib_set_gvc.f90
View File

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

90
examples/F90/grib_set_keys.f90
View File

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

56
examples/F90/grib_set_missing.f90
View File

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

66
examples/F90/grib_set_packing.f90
View File

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

84
examples/F90/grib_set_pv.f90
View File

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

66
examples/F90/iterator_fortran.f90
View File

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

72
examples/F90/keys_iterator_fortran.f90
View File

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

72
examples/F90/multi_fortran.f90
View File

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

41
examples/F90/new_from_file.f90
View File

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

124
examples/F90/precision_fortran.f90
View File

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

56
examples/F90/print_data_fortran.f90
View File

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

132
examples/F90/read_from_file.f90
View File

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

64
examples/F90/set_fortran.f90
View File

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

40
examples/F90/set_missing_fortran.f90
View File

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