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

81
examples/F90/bufr_attributes.f90
View File

@ -13,59 +13,58 @@
!
!
program bufr_attributes
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: count=0
integer(kind=4) :: iVal,conf
real(kind=8) :: t2m
character(len=32) :: units, confUnits
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: count = 0
integer(kind=4) :: iVal, conf
real(kind=8) :: t2m
character(len=32) :: units, confUnits
call codes_open_file(ifile,'../../data/bufr/syno_multi.bufr','r')
call codes_open_file(ifile, '../../data/bufr/syno_multi.bufr', 'r')
! the first bufr message is loaded from file
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
call codes_bufr_new_from_file(ifile, ibufr, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
! Get and print some keys form the BUFR header
write(*,*) 'message: ',count
write (*, *) 'message: ', count
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr,"unpack",1);
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
call codes_get(ibufr,'airTemperatureAt2M',t2m);
write(*,*) ' airTemperatureAt2M:',t2m
call codes_get(ibufr, 'airTemperatureAt2M', t2m);
write (*, *) ' airTemperatureAt2M:', t2m
! Get the element's code (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->code',iVal);
write(*,*) ' airTemperatureAt2M->code:',iVal
call codes_get(ibufr, 'airTemperatureAt2M->code', iVal);
write (*, *) ' airTemperatureAt2M->code:', iVal
! Get the element's units (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->units',units)
write(*,*) ' airTemperatureAt2M->units:',units
call codes_get(ibufr, 'airTemperatureAt2M->units', units)
write (*, *) ' airTemperatureAt2M->units:', units
! Get the element's scale (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->scale',iVal);
write(*,*) ' airTemperatureAt2M->code:',iVal
call codes_get(ibufr, 'airTemperatureAt2M->scale', iVal);
write (*, *) ' airTemperatureAt2M->code:', iVal
! Get the element's reference (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->reference',iVal);
write(*,*) ' airTemperatureAt2M->reference:',iVal
call codes_get(ibufr, 'airTemperatureAt2M->reference', iVal);
write (*, *) ' airTemperatureAt2M->reference:', iVal
! Get the element's width (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->width',iVal);
write(*,*) ' airTemperatureAt2M->width:',iVal
call codes_get(ibufr, 'airTemperatureAt2M->width', iVal);
write (*, *) ' airTemperatureAt2M->width:', iVal
! -------------------------------------------------------------------
! The 2m temperature data element in this message has an associated
@ -74,36 +73,36 @@ character(len=32) :: units, confUnits
! -------------------------------------------------------------------
! Get the element's value as as real
call codes_get(ibufr,'airTemperatureAt2M->percentConfidence',conf);
write(*,*) ' airTemperatureAt2M->percentConfidence:', conf
call codes_get(ibufr, 'airTemperatureAt2M->percentConfidence', conf);
write (*, *) ' airTemperatureAt2M->percentConfidence:', conf
! Get the element's code (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->percentConfidence->code',iVal);
write(*,*) ' airTemperatureAt2M->percentConfidence->code:',iVal
call codes_get(ibufr, 'airTemperatureAt2M->percentConfidence->code', iVal);
write (*, *) ' airTemperatureAt2M->percentConfidence->code:', iVal
! Get the element's units (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->percentConfidence->units',confUnits)
write(*,*) ' airTemperatureAt2M->percentConfidence->units:',confUnits
call codes_get(ibufr, 'airTemperatureAt2M->percentConfidence->units', confUnits)
write (*, *) ' airTemperatureAt2M->percentConfidence->units:', confUnits
! Get the element's scale (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->percentConfidence->scale',iVal);
write(*,*) ' airTemperatureAt2M->percentConfidence->code:',iVal
call codes_get(ibufr, 'airTemperatureAt2M->percentConfidence->scale', iVal);
write (*, *) ' airTemperatureAt2M->percentConfidence->code:', iVal
! Get the element's reference (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->percentConfidence->reference',iVal);
write(*,*) ' airTemperatureAt2M->percentConfidence->reference:',iVal
call codes_get(ibufr, 'airTemperatureAt2M->percentConfidence->reference', iVal);
write (*, *) ' airTemperatureAt2M->percentConfidence->reference:', iVal
! Get the element's width (see BUFR code table B)
call codes_get(ibufr,'airTemperatureAt2M->percentConfidence->width',iVal);
write(*,*) ' airTemperatureAt2M->percentConfidence->width:',iVal
call codes_get(ibufr, 'airTemperatureAt2M->percentConfidence->width', iVal);
write (*, *) ' airTemperatureAt2M->percentConfidence->width:', iVal
! Release the bufr message
call codes_release(ibufr)
! Load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
call codes_bufr_new_from_file(ifile, ibufr, iret)
count=count+1
count = count + 1
end do

16
examples/F90/bufr_clone.f90
View File

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

76
examples/F90/bufr_copy_data.f90
View File

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

2
examples/F90/bufr_copy_keys.f90
View File

@ -12,7 +12,7 @@ program bufr_copy_keys
use eccodes
implicit none
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(file2, '../../data/bufr/aaen_55.bufr', 'r')

16
examples/F90/bufr_copy_message.f90
View File

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

45
examples/F90/bufr_expanded.f90
View File

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

77
examples/F90/bufr_get_keys.f90
View File

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

28
examples/F90/bufr_get_string_array.f90
View File

@ -15,44 +15,44 @@ program bufr_get_string_array
use eccodes
implicit none
integer :: ifile
integer :: iret,i,n
integer :: iret, i, n
integer :: ibufr
integer :: strsize
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
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
call codes_get(ibufr,'stationOrSiteName->width',strsize)
call codes_get(ibufr, 'stationOrSiteName->width', strsize)
! 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
! back from the call to codes_get_string_array
if (strsize > max_strsize) then
print *,'stationOrSiteName array dimension is ',max_strsize,' and should be ',strsize
print *, 'stationOrSiteName array dimension is ', max_strsize, ' and should be ', strsize
call exit(1)
end if
! Allocating the array of strings to be passed to codes_get_string_array is mandatory
call codes_get_size(ibufr,'stationOrSiteName',n)
allocate(stationOrSiteName(n))
call codes_get_size(ibufr, 'stationOrSiteName', n)
allocate (stationOrSiteName(n))
! Passing an array of strings stationOrSiteName which must be allocated beforehand
call codes_get_string_array(ibufr,'stationOrSiteName',stationOrSiteName)
do i=1,n
write(*,'(A)')trim(stationOrSiteName(i))
call codes_get_string_array(ibufr, 'stationOrSiteName', stationOrSiteName)
do i = 1, n
write (*, '(A)') trim(stationOrSiteName(i))
end do
! Remember to deallocate
deallocate(stationOrSiteName)
deallocate (stationOrSiteName)
! Release memory associated with bufr handle
! ibufr won't be accessible after this

37
examples/F90/bufr_keys_iterator.f90
View File

@ -15,35 +15,34 @@
! keys in a BUFR message.
!
program bufr_keys_iterator
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: count=0
character(len=256) :: key
integer :: kiter
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: count = 0
character(len=256) :: key
integer :: kiter
call codes_open_file(ifile,'../../data/bufr/syno_1.bufr','r')
call codes_open_file(ifile, '../../data/bufr/syno_1.bufr', 'r')
! The first bufr message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
call codes_bufr_new_from_file(ifile, ibufr, iret)
do while (iret /= CODES_END_OF_FILE)
! 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
! 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)
call codes_bufr_keys_iterator_new(ibufr, kiter, iret)
if (iret .ne. 0) then
write(*,*) 'ERROR: Unable to create BUFR keys iterator'
write (*, *) 'ERROR: Unable to create BUFR keys iterator'
call exit(1)
end if
@ -53,8 +52,8 @@ integer :: kiter
! Loop over keys
do while (iret == CODES_SUCCESS)
! Print key name
call codes_bufr_keys_iterator_get_name(kiter,key)
write(*,*) ' ',trim(key)
call codes_bufr_keys_iterator_get_name(kiter, key)
write (*, *) ' ', trim(key)
! Get next key
call codes_bufr_keys_iterator_next(kiter, iret)
@ -67,9 +66,9 @@ integer :: kiter
call codes_release(ibufr)
! Load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
call codes_bufr_new_from_file(ifile, ibufr, iret)
count=count+1
count = count + 1
end do

64
examples/F90/bufr_read_header.f90
View File

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

77
examples/F90/bufr_read_scatterometer.f90
View File

@ -15,32 +15,30 @@
! below might not work directly for other types of messages than the one used in the
! example. It is advised to use bufr_dump first to understand the structure of these messages.
program bufr_read_scatterometer
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i, count=0
integer(kind=4) :: numObs,ii
real(kind=8), dimension(:), allocatable :: latVal,lonVal,bscatterVal
real(kind=8), dimension(:), allocatable :: year
use eccodes
implicit none
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i, count = 0
integer(kind=4) :: numObs, ii
real(kind=8), dimension(:), allocatable :: latVal, lonVal, bscatterVal
real(kind=8), dimension(:), allocatable :: year
call codes_open_file(ifile,'../../data/bufr/asca_139.bufr','r')
call codes_open_file(ifile, '../../data/bufr/asca_139.bufr', 'r')
! The first BUFR message is loaded from file,
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
call codes_bufr_new_from_file(ifile, ibufr, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
write(*,'(A,I3)') 'message: ',count
write (*, '(A,I3)') 'message: ', count
! We need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr,"unpack",1);
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.
@ -49,52 +47,49 @@ real(kind=8), dimension(:), allocatable :: year
! we will simply access the key by condition (see below).
! Read the total number of subsets.
call codes_get(ibufr,'numberOfSubsets',numObs)
call codes_get(ibufr, 'numberOfSubsets', numObs)
write(*,'(A,I5)') "Number of values:",numObs
write (*, '(A,I5)') "Number of values:", numObs
! Get latitude (for all the subsets)
call codes_get(ibufr,'latitude',latVal);
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)
enddo
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 backScatter for beam two. We use an access by condition for this key.
! (for all the subsets)
call codes_get(ibufr,'/beamIdentifier=2/backscatter',bscatterVal);
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'
if (size(latVal) /= numObs .or. size(lonVal) /= numObs .or. size(bscatterVal) /= numObs) then
print *, 'inconsistent array dimension'
exit
endif
end if
! Print the values
write(*,*) 'pixel lat lon backscatter'
write(*,*) "--------------------------------------"
write (*, *) 'pixel lat lon backscatter'
write (*, *) "--------------------------------------"
do i=1,numObs
write(*,'(I4,3F10.5)') i,latVal(i),lonVal(i),bscatterVal(i)
do i = 1, numObs
write (*, '(I4,3F10.5)') i, latVal(i), lonVal(i), bscatterVal(i)
end do
! Free arrays
deallocate(latVal)
deallocate(lonVal)
deallocate(bscatterVal)
deallocate (latVal)
deallocate (lonVal)
deallocate (bscatterVal)
! Release the bufr message
call codes_release(ibufr)
! Load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
call codes_bufr_new_from_file(ifile, ibufr, iret)
count=count+1
count = count + 1
end do

84
examples/F90/bufr_read_synop.f90
View File

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

84
examples/F90/bufr_read_temp.f90
View File

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

173
examples/F90/bufr_read_tempf.f90
View File

@ -23,152 +23,151 @@ program bufr_read_temp
integer :: ifile
integer :: iret
integer :: ibufr
integer :: i, count=0
integer :: i, count = 0
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(kind=4) :: sizews
integer(kind=4) :: blockNumber,stationNumber
integer(kind=4) :: ymd,hms
integer(kind=4) :: blockNumber, stationNumber
integer(kind=4) :: ymd, hms
logical :: llstdonly = .True. ! Set True to list standard levels only
logical :: llskip
real(kind=8) :: year,month,day,hour,minute,second
real(kind=8) :: htg,htp,htec=0,sondeType
real(kind=8), dimension(:), allocatable :: lat,lon
real(kind=8), dimension(:), allocatable :: timeVal,dlatVal,dlonVal,vssVal
real(kind=8), dimension(:), allocatable :: presVal,zVal,tVal,tdVal,wdirVal,wspVal
real(kind=8) :: year, month, day, hour, minute, second
real(kind=8) :: htg, htp, htec = 0, sondeType
real(kind=8), dimension(:), allocatable :: lat, lon
real(kind=8), dimension(:), allocatable :: timeVal, dlatVal, dlonVal, vssVal
real(kind=8), dimension(:), allocatable :: presVal, zVal, tVal, tdVal, wdirVal, wspVal
character(len=128) :: statid
character(len=16) :: rsnumber
character(len=16) :: rssoftware
character(len=8) :: Note
call codes_open_file(ifile,'../../data/bufr/PraticaTemp.bufr','r')
call codes_open_file(ifile, '../../data/bufr/PraticaTemp.bufr', 'r')
! the first bufr message is loaded from file
! ibufr is the bufr id to be used in subsequent calls
call codes_bufr_new_from_file(ifile,ibufr,iret)
call codes_bufr_new_from_file(ifile, ibufr, iret)
! do while (iret/=CODES_END_OF_FILE)
do while (iret/=CODES_END_OF_FILE .AND. status_time==CODES_SUCCESS)
do while (iret /= CODES_END_OF_FILE .AND. status_time == CODES_SUCCESS)
! we need to instruct ecCodes to expand all the descriptors
! i.e. unpack the data values
call codes_set(ibufr,"unpack",1);
call codes_set(ibufr, "unpack", 1);
! In our BUFR message verticalSoundingSignificance is always followed by
! geopotential, airTemperature, dewpointTemperature,
! windDirection, windSpeed and pressure.
!
count=count+1
llskip=.False.
count = count + 1
llskip = .False.
! Metadata:
call codes_get(ibufr,'shipOrMobileLandStationIdentifier',statid,status_id)
call codes_get(ibufr, 'shipOrMobileLandStationIdentifier', statid, status_id)
IF (status_id /= CODES_SUCCESS) statid = "UNKNOWN"
call codes_is_missing(ibufr,'shipOrMobileLandStationIdentifier',statid_missing)
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)
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)
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)
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)
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)
ymd = INT(year)*10000 + INT(month)*100 + INT(day)
hms = INT(hour)*10000 + INT(minute)*100 + INT(second)
call codes_get(ibufr, 'radiosondeSerialNumber', rsnumber, status_rsno)
call codes_get(ibufr, 'softwareVersionNumber', rssoftware, status_rssoft)
! Ascent (skip incomplete reports for now)
call codes_get(ibufr,'timePeriod',timeVal,status_time)
call codes_get(ibufr, 'timePeriod', timeVal, status_time)
IF (status_time /= CODES_SUCCESS) THEN
write(*,'(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ',count, &
' ',blockNumber,' ',stationNumber,ymd,hms,lat(1),lon(1),htg,htp,INT(sondeType)
write(*,'(A)') 'Missing times - skip'
llskip=.True.
ENDIF
call codes_get(ibufr,'pressure',presVal,status_p)
write (*, '(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ', count, &
' ', blockNumber, ' ', stationNumber, ymd, hms, lat(1), lon(1), htg, htp, INT(sondeType)
write (*, '(A)') 'Missing times - skip'
llskip = .True.
END IF
call codes_get(ibufr, 'pressure', presVal, status_p)
IF (status_p /= CODES_SUCCESS) THEN
write(*,'(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ',count, &
' ',blockNumber,' ',stationNumber,ymd,hms,lat(1),lon(1),htg,htp,INT(sondeType)
write(*,'(A)') 'Missing pressures - skip'
llskip=.True.
ENDIF
call codes_get(ibufr,'nonCoordinateGeopotentialHeight',zVal,status_ht)
write (*, '(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ', count, &
' ', blockNumber, ' ', stationNumber, ymd, hms, lat(1), lon(1), htg, htp, INT(sondeType)
write (*, '(A)') 'Missing pressures - skip'
llskip = .True.
END IF
call codes_get(ibufr, 'nonCoordinateGeopotentialHeight', zVal, status_ht)
IF (status_ht /= CODES_SUCCESS) THEN
write(*,'(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ',count, &
' ',blockNumber,' ',stationNumber,ymd,hms,lat(1),lon(1),htg,htp,INT(sondeType)
write(*,'(A)') 'Missing heights - skip'
llskip=.True.
ENDIF
write (*, '(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4)') 'Ob: ', count, &
' ', blockNumber, ' ', stationNumber, ymd, hms, lat(1), lon(1), htg, htp, INT(sondeType)
write (*, '(A)') 'Missing heights - skip'
llskip = .True.
END IF
! IF (blockNumber /= 17 .OR. stationNumber /= 196) llskip=.True. ! FIX
! IF (blockNumber /= 17.0) llskip=.True. ! FIX
IF (.NOT.llskip) THEN
call codes_get(ibufr,'latitudeDisplacement',dlatVal)
call codes_get(ibufr,'longitudeDisplacement',dlonVal)
call codes_get(ibufr,'extendedVerticalSoundingSignificance',vssVal)
IF (.NOT. llskip) THEN
call codes_get(ibufr, 'latitudeDisplacement', dlatVal)
call codes_get(ibufr, 'longitudeDisplacement', dlonVal)
call codes_get(ibufr, 'extendedVerticalSoundingSignificance', vssVal)
!call codes_get(ibufr,'geopotentialHeight',zVal)
call codes_get(ibufr,'airTemperature',tVal)
call codes_get(ibufr,'dewpointTemperature',tdVal)
call codes_get(ibufr,'windDirection',wdirVal)
call codes_get(ibufr,'windSpeed',wspVal)
call codes_get(ibufr, 'airTemperature', tVal)
call codes_get(ibufr, 'dewpointTemperature', tdVal)
call codes_get(ibufr, 'windDirection', wdirVal)
call codes_get(ibufr, 'windSpeed', wspVal)
! ---- Array sizes (pressure size can be larger - wind shear levels)
sizews = size(wspVal)
! ---- Print the values --------------------------------
write(*,'(A,A72)') 'Statid: ',statid
write(*,'(A,I7,A,I2.2,A,I3.3,I9,I7.6,F9.3,F10.3,2F7.1,I4,I5)') 'Ob: ',count, &
' ',blockNumber,' ',stationNumber,ymd,hms,lat(1),lon(1),htg,htp,INT(sondeType),sizews
IF (status_ht == CODES_SUCCESS) write(*,'(A,F9.3,F10.3,F7.1)') &
'WMO list lat, lon, ht: ', lat(1),lon(1),htec
IF (status_rsno == CODES_SUCCESS) write(*,'(A,A,A)') &
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
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 (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
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
! free arrays
deallocate(dlatVal,dlonVal,vssVal)
deallocate(presVal,zVal,tVal,tdVal,wdirVal,wspVal)
deallocate (dlatVal, dlonVal, vssVal)
deallocate (presVal, zVal, tVal, tdVal, wdirVal, wspVal)
END IF
IF (ALLOCATED(timeVal)) deallocate(timeVal)
IF (ALLOCATED(timeVal)) deallocate (timeVal)
! release the bufr message
call codes_release(ibufr)
! load the next bufr message
call codes_bufr_new_from_file(ifile,ibufr,iret)
call codes_bufr_new_from_file(ifile, ibufr, iret)
end do

362
examples/F90/bufr_read_tropical_cyclone.f90
View File

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

32
examples/F90/bufr_set_keys.f90
View File

@ -15,48 +15,48 @@ program bufr_set_keys
use eccodes
implicit none
integer :: iret
integer :: infile,outfile
integer :: infile, outfile
integer :: ibufr
integer :: count=0
integer :: count = 0
integer(kind=4) :: centre, centreNew
! 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
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,
! 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
! E.g. we change the centre
! Set centre
centre=222
call codes_set(ibufr,'bufrHeaderCentre',222)
write(*,*) ' set bufrHeaderCentre to:',centre
centre = 222
call codes_set(ibufr, 'bufrHeaderCentre', 222)
write (*, *) ' set bufrHeaderCentre to:', centre
! Check centre's new value
centreNew=0
call codes_get(ibufr,'bufrHeaderCentre',centreNew)
write(*,*) ' bufrHeaderCentre''s new value:',centreNew
centreNew = 0
call codes_get(ibufr, 'bufrHeaderCentre', centreNew)
write (*, *) ' bufrHeaderCentre''s new value:', centreNew
! Write modified message to a file
call codes_write(ibufr,outfile)
call codes_write(ibufr, outfile)
! Release the handle
call codes_release(ibufr)
! 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

57
examples/F90/bufr_subset.f90
View File

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

56
examples/F90/get_fortran.f90
View File

@ -10,8 +10,8 @@
!
!
program get
use eccodes
implicit none
use eccodes
implicit none
integer :: ifile
integer :: iret
@ -23,95 +23,95 @@ implicit none
real(kind=8) :: longitudeOfLastPointInDegrees
real(kind=8) :: jDirectionIncrementInDegrees
real(kind=8) :: iDirectionIncrementInDegrees
integer(kind = 4) :: numberOfPointsAlongAParallel
integer(kind = 4) :: numberOfPointsAlongAMeridian
integer(kind=4) :: numberOfPointsAlongAParallel
integer(kind=4) :: numberOfPointsAlongAMeridian
real(kind=8), dimension(:), allocatable :: values
integer(kind = 4) :: numberOfValues
integer(kind=4) :: numberOfValues
real(kind=8) :: average
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
! 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
call codes_get(igrib,'numberOfPointsAlongAParallel', &
call codes_get(igrib, 'numberOfPointsAlongAParallel', &
numberOfPointsAlongAParallel)
write(*,*) 'numberOfPointsAlongAParallel=', &
write (*, *) 'numberOfPointsAlongAParallel=', &
numberOfPointsAlongAParallel
! get as a integer
call codes_get(igrib,'numberOfPointsAlongAMeridian', &
call codes_get(igrib, 'numberOfPointsAlongAMeridian', &
numberOfPointsAlongAMeridian)
write(*,*) 'numberOfPointsAlongAMeridian=', &
write (*, *) 'numberOfPointsAlongAMeridian=', &
numberOfPointsAlongAMeridian
! get as a real8
call codes_get(igrib, &
'latitudeOfFirstGridPointInDegrees', &
latitudeOfFirstPointInDegrees)
write(*,*) 'latitudeOfFirstGridPointInDegrees=', &
write (*, *) 'latitudeOfFirstGridPointInDegrees=', &
latitudeOfFirstPointInDegrees
! get as a real8
call codes_get(igrib, &
'longitudeOfFirstGridPointInDegrees', &
longitudeOfFirstPointInDegrees)
write(*,*) 'longitudeOfFirstGridPointInDegrees=', &
write (*, *) 'longitudeOfFirstGridPointInDegrees=', &
longitudeOfFirstPointInDegrees
! get as a real8
call codes_get(igrib, &
'latitudeOfLastGridPointInDegrees', &
latitudeOfLastPointInDegrees)
write(*,*) 'latitudeOfLastGridPointInDegrees=', &
write (*, *) 'latitudeOfLastGridPointInDegrees=', &
latitudeOfLastPointInDegrees
! get as a real8
call codes_get(igrib, &
'longitudeOfLastGridPointInDegrees', &
longitudeOfLastPointInDegrees)
write(*,*) 'longitudeOfLastGridPointInDegrees=', &
write (*, *) 'longitudeOfLastGridPointInDegrees=', &
longitudeOfLastPointInDegrees
! get as a real8
call codes_get(igrib, &
'jDirectionIncrementInDegrees', &
jDirectionIncrementInDegrees)
write(*,*) 'jDirectionIncrementInDegrees=', &
write (*, *) 'jDirectionIncrementInDegrees=', &
jDirectionIncrementInDegrees
! get as a real8
call codes_get(igrib, &
'iDirectionIncrementInDegrees', &
iDirectionIncrementInDegrees)
write(*,*) 'iDirectionIncrementInDegrees=', &
write (*, *) 'iDirectionIncrementInDegrees=', &
iDirectionIncrementInDegrees
! get the size of the values array
call codes_get_size(igrib,'values',numberOfValues)
write(*,*) 'numberOfValues=',numberOfValues
call codes_get_size(igrib, 'values', numberOfValues)
write (*, *) 'numberOfValues=', numberOfValues
allocate(values(2*numberOfValues), stat=iret)
allocate (values(2*numberOfValues), stat=iret)
! get data values
print*, size(values)
call codes_get(igrib,'values',values)
print *, size(values)
call codes_get(igrib, 'values', values)
average = 0
do i=1,numberOfValues
do i = 1, numberOfValues
average = average + values(i);
enddo
end do
average =average / numberOfValues
average = average/numberOfValues
write(*,*)'There are ',numberOfValues, &
' average is ',average
write (*, *) 'There are ', numberOfValues, &
' average is ', average
call codes_release(igrib)
call codes_close_file(ifile)
deallocate(values)
deallocate (values)
end program get

38
examples/F90/get_product_kind.f90
View File

@ -18,45 +18,45 @@ program get_product_kind
integer :: ifile
integer :: iret
integer :: ihandle
integer :: count=0
integer :: version=0
integer :: count = 0
integer :: version = 0
character(len=32) :: product_kind
character(len=120) :: infile_name
call getarg(1, infile_name)
write(*,*) 'infile_name|',infile_name,'|'
call codes_open_file(ifile,infile_name,'r')
write (*, *) 'infile_name|', infile_name, '|'
call codes_open_file(ifile, infile_name, 'r')
call codes_get_api_version(version)
write(*,*) 'API version: ',version
write (*, *) 'API version: ', version
write(*,*) 'ecCodes settings: '
write(*,*) ' ECCODES_POSIX_THREADS: ',ECCODES_SETTINGS_POSIX_THREADS
write(*,*) ' ECCODES_OMP_THREADS: ',ECCODES_SETTINGS_OMP_THREADS
write(*,*) ' ECCODES_SETTINGS_MEMFS: ',ECCODES_SETTINGS_MEMFS
write(*,*) ' ECCODES_SETTINGS_JPEG: ',ECCODES_SETTINGS_JPEG
write(*,*) ' ECCODES_SETTINGS_PNG: ',ECCODES_SETTINGS_PNG
write(*,*) ' ECCODES_SETTINGS_AEC: ',ECCODES_SETTINGS_AEC
write (*, *) 'ecCodes settings: '
write (*, *) ' ECCODES_POSIX_THREADS: ', ECCODES_SETTINGS_POSIX_THREADS
write (*, *) ' ECCODES_OMP_THREADS: ', ECCODES_SETTINGS_OMP_THREADS
write (*, *) ' ECCODES_SETTINGS_MEMFS: ', ECCODES_SETTINGS_MEMFS
write (*, *) ' ECCODES_SETTINGS_JPEG: ', ECCODES_SETTINGS_JPEG
write (*, *) ' ECCODES_SETTINGS_PNG: ', ECCODES_SETTINGS_PNG
write (*, *) ' ECCODES_SETTINGS_AEC: ', ECCODES_SETTINGS_AEC
! the first message is loaded from file
! ihandle is the message id to be used in subsequent calls
call codes_new_from_file(ifile,ihandle,CODES_PRODUCT_ANY,iret)
call codes_new_from_file(ifile, ihandle, CODES_PRODUCT_ANY, iret)
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
write(*,*) 'message: ',count
write (*, *) 'message: ', count
! get the product kind
call codes_get(ihandle,'kindOfProduct',product_kind)
write(*,*) ' product: ',product_kind
call codes_get(ihandle, 'kindOfProduct', product_kind)
write (*, *) ' product: ', product_kind
! release the message
call codes_release(ihandle)
! 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

38
examples/F90/grib_clone.f90
View File

@ -16,60 +16,60 @@
program clone
use eccodes
implicit none
integer :: err,i
integer :: err, i
integer :: nx, ny
integer :: infile,outfile
integer :: infile, outfile
integer :: igrib_in
integer :: igrib_out
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(outfile,'out.clone.grib1','w')
call codes_open_file(infile, '../../data/constant_field.grib1', 'r')
call codes_open_file(outfile, 'out.clone.grib1', 'w')
! A new GRIB message is loaded from file.
! igrib is the GRIB id to be used in subsequent calls
call codes_grib_new_from_file(infile,igrib_in)
call codes_grib_new_from_file(infile, igrib_in)
call codes_get(igrib_in,'Ni', nx)
call codes_get(igrib_in,'Nj', ny)
call codes_get(igrib_in, 'Ni', nx)
call codes_get(igrib_in, 'Nj', ny)
allocate(field2D(nx,ny),stat=err)
allocate (field2D(nx, ny), stat=err)
if (err .ne. 0) then
print*, 'Failed to allocate ', nx*ny, ' values'
print *, 'Failed to allocate ', nx*ny, ' values'
STOP
end if
! clone the constant field to create 4 new GRIB messages
do i=0,18,6
do i = 0, 18, 6
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.)
! 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)
! 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
call codes_write(igrib_out,outfile)
call codes_write(igrib_out, outfile)
call codes_release(igrib_out)
end do
call codes_release(igrib_in)
call codes_close_file(infile)
call codes_close_file(outfile)
deallocate(field2D)
deallocate (field2D)
contains
!======================================
subroutine generate_field(gfield2D)
real(kind=8), dimension(:,:) :: gfield2D
subroutine generate_field(gfield2D)
real(kind=8), dimension(:, :) :: gfield2D
call random_number(gfield2D)
end subroutine generate_field
end subroutine generate_field
!======================================
end program clone

15
examples/F90/grib_copy_message.f90
View File

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

4
examples/F90/grib_copy_namespace.f90
View File

@ -14,11 +14,11 @@ program copy_namespace
use eccodes
implicit none
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(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(file2, igrib2)

63
examples/F90/grib_count_messages.f90
View File

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

14
examples/F90/grib_count_messages_multi.f90
View File

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

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

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

62
examples/F90/grib_get_data.f90
View File

@ -11,68 +11,68 @@
!
!
program get_data
use eccodes
implicit none
use eccodes
implicit none
integer :: ifile
integer :: iret,i
real(kind=8),dimension(:),allocatable :: lats,lons,values
integer,dimension(:),allocatable :: bitmap
integer :: iret, i
real(kind=8), dimension(:), allocatable :: lats, lons, values
integer, dimension(:), allocatable :: bitmap
integer(4) :: numberOfPoints
logical :: is_missing_value
integer :: count1=0, count2=0, bitmapPresent=0, bmp_len=0
integer :: count1 = 0, count2 = 0, bitmapPresent = 0, bmp_len = 0
! Message identifier.
integer :: igrib
ifile=5
ifile = 5
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.
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)
count1=count1+1
print *, "===== Message #",count1
call codes_get(igrib,'numberOfPoints',numberOfPoints)
call codes_get(igrib,'bitmapPresent',bitmapPresent)
do while (iret /= CODES_END_OF_FILE)
count1 = count1 + 1
print *, "===== Message #", count1
call codes_get(igrib, 'numberOfPoints', numberOfPoints)
call codes_get(igrib, 'bitmapPresent', bitmapPresent)
allocate(lats(numberOfPoints))
allocate(lons(numberOfPoints))
allocate(values(numberOfPoints))
allocate (lats(numberOfPoints))
allocate (lons(numberOfPoints))
allocate (values(numberOfPoints))
if (bitmapPresent == 1) then
! get the bitmap
call codes_get_size(igrib, 'bitmap', bmp_len)
allocate(bitmap(bmp_len))
call codes_get(igrib,'bitmap', bitmap)
allocate (bitmap(bmp_len))
call codes_get(igrib, 'bitmap', bitmap)
end if
call codes_grib_get_data(igrib,lats,lons,values)
call codes_grib_get_data(igrib, lats, lons, values)
do i=1,numberOfPoints
do i = 1, numberOfPoints
! Consult bitmap to see if the i'th value is missing
is_missing_value=.false.
is_missing_value = .false.
if (bitmapPresent == 1 .and. bitmap(i) == 0) then
is_missing_value=.true.
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
print *, lats(i), lons(i), values(i)
count2 = count2 + 1
end if
enddo
print *, 'count of non-missing values=',count2
end do
print *, 'count of non-missing values=', count2
if (count2 /= 214661) then
call codes_check(-2, 'incorrect number of missing', '')
end if
deallocate(lats)
deallocate(lons)
deallocate(values)
deallocate (lats)
deallocate (lons)
deallocate (values)
call codes_release(igrib)
call codes_grib_new_from_file(ifile,igrib, iret)
call codes_grib_new_from_file(ifile, igrib, iret)
end do

54
examples/F90/grib_get_keys.f90
View File

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

22
examples/F90/grib_get_pl.f90
View File

@ -19,24 +19,24 @@ program grib_get_pl
real, dimension(:), allocatable :: pl
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
! 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
call codes_get(igrib,'PLPresent',PLPresent)
print*, "PLPresent= ", PLPresent
call codes_get(igrib, 'PLPresent', PLPresent)
print *, "PLPresent= ", PLPresent
if (PLPresent == 1) then
call codes_get_size(igrib,'pl',nb_pl)
print*, "there are ", nb_pl, " PL values"
allocate(pl(nb_pl))
call codes_get(igrib,'pl',pl)
print*, "pl = ", pl
deallocate(pl)
call codes_get_size(igrib, 'pl', nb_pl)
print *, "there are ", nb_pl, " PL values"
allocate (pl(nb_pl))
call codes_get(igrib, 'pl', pl)
print *, "pl = ", pl
deallocate (pl)
else
print*, "There is no PL values in your GRIB message!"
print *, "There is no PL values in your GRIB message!"
end if
call codes_release(igrib)

22
examples/F90/grib_get_pv.f90
View File

@ -19,24 +19,24 @@ program grib_get_pv
real, dimension(:), allocatable :: pv
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
! 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
call codes_get(igrib,'PVPresent',PVPresent)
print*, "PVPresent = ", PVPresent
call codes_get(igrib, 'PVPresent', PVPresent)
print *, "PVPresent = ", PVPresent
if (PVPresent == 1) then
call codes_get_size(igrib,'pv',nb_pv)
print*, "There are ", nb_pv, " PV values"
allocate(pv(nb_pv))
call codes_get(igrib,'pv',pv)
print*, "pv = ", pv
deallocate(pv)
call codes_get_size(igrib, 'pv', nb_pv)
print *, "There are ", nb_pv, " PV values"
allocate (pv(nb_pv))
call codes_get(igrib, 'pv', pv)
print *, "pv = ", pv
deallocate (pv)
else
print*, "There is no PV values in your GRIB message!"
print *, "There is no PV values in your GRIB message!"
end if
call codes_release(igrib)

52
examples/F90/grib_get_set_uuid.f90
View File

@ -17,44 +17,44 @@ program grib_get_set_uuid
integer :: infile, outfile
integer :: igrib, ogrib
integer :: count1, i, iret, nvg, ffs, length
character(len=1) :: uuid_in (16) ! Array of 16 bytes for uuid on input.
character(len=1) :: uuid_in(16) ! Array of 16 bytes for uuid on input.
character(len=1) :: uuid_out(16) ! Array of 16 bytes for uuid on output.
character(len=32) :: uuid_string ! Human-readable uuid.
character(len=32) :: uuid_string_expected ! Expected UUID of input
call codes_open_file (infile, '../../data/test_uuid.grib2','r')
call codes_open_file(infile, '../../data/test_uuid.grib2', 'r')
call codes_open_file (outfile, 'out_uuid.grib2','w')
call codes_open_file(outfile, 'out_uuid.grib2', 'w')
! Load first grib message from file
! igrib is the grib id to be used in subsequent calls
call codes_grib_new_from_file (infile, igrib, iret)
call codes_grib_new_from_file(infile, igrib, iret)
uuid_string_expected = '08b1e836bc6911e1951fb51b5624ad8d'
count1 = 0
do while (iret/=CODES_END_OF_FILE)
do while (iret /= CODES_END_OF_FILE)
count1 = count1 + 1
print *, "### Record:", count1
call codes_get(igrib,'typeOfFirstFixedSurface',ffs)
call codes_get(igrib, 'typeOfFirstFixedSurface', ffs)
print *, 'typeOfFirstFixedSurface =', ffs
if (ffs /= 150) then
print *, "Unexpected typeOfFirstFixedSurface (must be 150)."
stop
end if
call codes_get (igrib,'numberOfVGridUsed',nvg)
print *, 'numberOfVGridUsed =',nvg
call codes_get(igrib, 'numberOfVGridUsed', nvg)
print *, 'numberOfVGridUsed =', nvg
! call codes_get (igrib,'uuidOfVGrid',uuid_in) ! Assuming length is ok.
call codes_get (igrib,'uuidOfVGrid',uuid_in,length=length)
call codes_get(igrib, 'uuidOfVGrid', uuid_in, length=length)
if (length /= 16) then
print *, "Sorry, bad length of byte_array:", length, ". Expected: 16"
stop
end if
! Convert byte array to hexadecimal string for printing
do i = 1, size (uuid_in)
uuid_string(2*i-1:2*i) = byte2hex(uuid_in(i))
do i = 1, size(uuid_in)
uuid_string(2*i - 1:2*i) = byte2hex(uuid_in(i))
end do
print *, "uuidOfVGrid (on input) = ", uuid_string
if (uuid_string .ne. uuid_string_expected) then
@ -62,39 +62,39 @@ program grib_get_set_uuid
stop
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)
uuid_out(1:16) = uuid_in(16:1:-1)
call codes_set (ogrib,'uuidOfVGrid',uuid_out)
call codes_write (ogrib,outfile)
call codes_set(ogrib, 'uuidOfVGrid', uuid_out)
call codes_write(ogrib, outfile)
call codes_release (igrib)
call codes_release (ogrib)
call codes_grib_new_from_file (infile, igrib, iret)
call codes_release(igrib)
call codes_release(ogrib)
call codes_grib_new_from_file(infile, igrib, iret)
end do
call codes_close_file (infile)
call codes_close_file (outfile)
call codes_close_file(infile)
call codes_close_file(outfile)
contains
! Convert single byte to 'hexadecimal' string
pure function byte2hex (c) result (hex)
pure function byte2hex(c) result(hex)
character(len=1), intent(in) :: c
character(len=2) :: hex
integer :: x
x = iachar (c)
hex(1:1) = nibble ( x / 16)
hex(2:2) = nibble (iand (x, 15))
x = iachar(c)
hex(1:1) = nibble(x/16)
hex(2:2) = nibble(iand(x, 15))
end function byte2hex
! Convert 'nibble' to 'hexadecimal'
pure function nibble (x)
pure function nibble(x)
integer, intent(in) :: x
character :: nibble
select case (x)
case (0:9)
nibble = achar (iachar ('0') + x)
nibble = achar(iachar('0') + x)
case default
nibble = achar (iachar ('a') - 10 + x)
nibble = achar(iachar('a') - 10 + x)
end select
end function nibble
end program grib_get_set_uuid

100
examples/F90/grib_index.f90
View File

@ -17,84 +17,84 @@ program index
implicit none
integer :: iret
integer,dimension(:),allocatable :: step,level,number
character(len=20),dimension(:),allocatable :: shortName
integer :: ostep,olevel,onumber
integer, dimension(:), allocatable :: step, level, number
character(len=20), dimension(:), allocatable :: shortName
integer :: ostep, olevel, onumber
character(len=20) :: oshortName
integer :: shortNameSize,numberSize,levelSize,stepSize
integer :: i,j,k,l
integer :: idx,igrib,count1
character(len=10) :: index_file='index.idx'
integer :: shortNameSize, numberSize, levelSize, stepSize
integer :: i, j, k, l
integer :: idx, igrib, count1
character(len=10) :: index_file = 'index.idx'
! uncomment following line to load index from file
!call codes_index_read(idx,index_file)
! 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
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(shortName(shortNameSize))
allocate (shortName(shortNameSize))
! get the list of distinct shortName from the index
call codes_index_get(idx,'shortName',shortName)
write(*,'(a,i3)') 'shortNameSize=',shortNameSize
call codes_index_get(idx, 'shortName', shortName)
write (*, '(a,i3)') 'shortNameSize=', shortNameSize
! get the number of distinct values of number in the index
call codes_index_get_size(idx,'number',numberSize)
call codes_index_get_size(idx, 'number', numberSize)
! 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
call codes_index_get(idx,'number',number)
write(*,'(a,i3)') 'numberSize=',numberSize
call codes_index_get(idx, 'number', number)
write (*, '(a,i3)') 'numberSize=', numberSize
! get the number of distinct values of level in the index
call codes_index_get_size(idx,'level',levelSize)
call codes_index_get_size(idx, 'level', levelSize)
! 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
call codes_index_get(idx,'level',level)
write(*,'(a,i3)') 'levelSize=',levelSize
call codes_index_get(idx, 'level', level)
write (*, '(a,i3)') 'levelSize=', levelSize
! get the number of distinct values of step in the index
call codes_index_get_size(idx,'step',stepSize)
call codes_index_get_size(idx, 'step', stepSize)
! 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
call codes_index_get(idx,'step',step)
write(*,'(a,i3)') 'stepSize=',stepSize
call codes_index_get(idx, 'step', step)
write (*, '(a,i3)') 'stepSize=', stepSize
count1=0
do l=1,stepSize ! loop on step
count1 = 0
do l = 1, stepSize ! loop on step
! 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)
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)
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)
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)
count1=count1+1
call codes_get(igrib,'shortName',oshortName)
call codes_get(igrib,'number',onumber)
call codes_get(igrib,'level',olevel)
call codes_get(igrib,'step',ostep)
write(*,'(A,A,A,i3,A,i4,A,i3)') 'shortName=',trim(oshortName),&
' number=',onumber,&
' level=' ,olevel, &
' step=' ,ostep
count1 = count1 + 1
call codes_get(igrib, 'shortName', oshortName)
call codes_get(igrib, 'number', onumber)
call codes_get(igrib, 'level', olevel)
call codes_get(igrib, 'step', ostep)
write (*, '(A,A,A,i3,A,i4,A,i3)') 'shortName=', trim(oshortName), &
' number=', onumber, &
' level=', olevel, &
' step=', ostep
call codes_release(igrib)
call codes_new_from_index(idx,igrib, iret)
call codes_new_from_index(idx, igrib, iret)
end do
call codes_release(igrib)
@ -102,16 +102,16 @@ program index
end do ! loop on level
end do ! loop on number
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
call codes_index_write(idx,index_file)
call codes_index_write(idx, index_file)
call codes_index_release(idx)
deallocate(level)
deallocate(shortName)
deallocate(step)
deallocate(number)
deallocate (level)
deallocate (shortName)
deallocate (step)
deallocate (number)
end program index

27
examples/F90/grib_keys_iterator.f90
View File

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

16
examples/F90/grib_multi.f90
View File

@ -17,10 +17,10 @@ program multi
implicit none
integer :: iret
integer(kind = 4) :: step
integer :: ifile,igrib
integer(kind=4) :: step
integer :: ifile, igrib
call codes_open_file(ifile, '../../data/multi_created.grib2','r')
call codes_open_file(ifile, '../../data/multi_created.grib2', 'r')
! turn on support for multi-field messages */
call codes_grib_multi_support_on()
@ -28,16 +28,16 @@ program multi
! turn off support for multi-field messages */
!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.
write(*,*) 'step'
write (*, *) 'step'
do while (iret /= CODES_END_OF_FILE)
call codes_get(igrib,'step', step)
write(*,'(i3)') step
call codes_get(igrib, 'step', step)
write (*, '(i3)') step
call codes_grib_new_from_file(ifile,igrib, iret)
call codes_grib_new_from_file(ifile, igrib, iret)
end do
call codes_close_file(ifile)

22
examples/F90/grib_multi_write.f90
View File

@ -17,30 +17,30 @@
program grib2_multi_write
use eccodes
implicit none
integer :: infile,outfile
integer :: infile, outfile
integer :: in_gribid
integer :: multi_gribid
integer :: step,startsection
integer :: step, startsection
! 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
! 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
do step=0,240,12
startsection = 4
do step = 0, 240, 12
call codes_set(in_gribid,"step",step)
call codes_grib_multi_append(in_gribid,startsection,multi_gribid)
call codes_set(in_gribid, "step", step)
call codes_grib_multi_append(in_gribid, startsection, multi_gribid)
enddo
end do
! write messages to a file
call codes_grib_multi_write(multi_gribid,outfile)
call codes_grib_multi_write(multi_gribid, outfile)
call codes_release(in_gribid)
call codes_release(multi_gribid)

58
examples/F90/grib_nearest.f90
View File

@ -23,56 +23,56 @@ program find
integer(kind=kindOfInt), dimension(:), allocatable :: indexes
! initialization
open( unit=1, file="../../data/list_points",form="formatted",action="read")
read(unit=1,fmt=*) npoints
allocate(lats(npoints))
allocate(lons(npoints))
allocate(nearest_lats(npoints))
allocate(nearest_lons(npoints))
allocate(distances(npoints))
allocate(lsm_values(npoints))
allocate(values(npoints))
allocate(indexes(npoints))
do i=1,npoints
read(unit=1,fmt=*, iostat=ios) lats(i), lons(i)
open (unit=1, file="../../data/list_points", form="formatted", action="read")
read (unit=1, fmt=*) npoints
allocate (lats(npoints))
allocate (lons(npoints))
allocate (nearest_lats(npoints))
allocate (nearest_lons(npoints))
allocate (distances(npoints))
allocate (lsm_values(npoints))
allocate (values(npoints))
allocate (indexes(npoints))
do i = 1, npoints
read (unit=1, fmt=*, iostat=ios) lats(i), lons(i)
if (ios /= 0) then
npoints = i - 1
exit
end if
end do
close(unit=1)
close (unit=1)
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
! 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_close_file(infile)
! will apply it to another GRIB
call codes_open_file(infile, &
'../../data/reduced_gaussian_pressure_level.grib1','r')
call codes_grib_new_from_file(infile,igrib)
'../../data/reduced_gaussian_pressure_level.grib1', 'r')
call codes_grib_new_from_file(infile, igrib)
call codes_get_element(igrib,"values", indexes, values)
call codes_get_element(igrib, "values", indexes, values)
call codes_release(igrib)
call codes_close_file(infile)
do i=1, npoints
print*,lats(i), lons(i), nearest_lats(i), nearest_lons(i), distances(i), lsm_values(i), values(i)
do i = 1, npoints
print *, lats(i), lons(i), nearest_lats(i), nearest_lons(i), distances(i), lsm_values(i), values(i)
end do
deallocate(lats)
deallocate(lons)
deallocate(nearest_lats)
deallocate(nearest_lons)
deallocate(distances)
deallocate(lsm_values)
deallocate(values)
deallocate(indexes)
deallocate (lats)
deallocate (lons)
deallocate (nearest_lats)
deallocate (nearest_lons)
deallocate (distances)
deallocate (lsm_values)
deallocate (values)
deallocate (indexes)
end program find

82
examples/F90/grib_precision.f90
View File

@ -15,73 +15,73 @@
program precision
use eccodes
implicit none
integer(kind = 4) :: size1
integer :: infile,outfile
integer(kind=4) :: size1
integer :: infile, outfile
integer :: igrib
real(kind = 8), dimension(:), allocatable :: values1
real(kind = 8), dimension(:), allocatable :: values2
real(kind = 8) :: maxa,a,maxv,minv,maxr,r
integer( kind = 4) :: decimalPrecision,bitsPerValue1,bitsPerValue2
real(kind=8), dimension(:), allocatable :: values1
real(kind=8), dimension(:), allocatable :: values2
real(kind=8) :: maxa, a, maxv, minv, maxr, r
integer(kind=4) :: decimalPrecision, bitsPerValue1, bitsPerValue2
integer :: i, iret
call codes_open_file(infile, &
'../../data/regular_latlon_surface_constant.grib1','r')
'../../data/regular_latlon_surface_constant.grib1', 'r')
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
! 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
call codes_get(igrib,'bitsPerValue',bitsPerValue1)
call codes_get(igrib, 'bitsPerValue', bitsPerValue1)
! 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(values2(size1), stat=iret)
allocate (values1(size1), stat=iret)
allocate (values2(size1), stat=iret)
! 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
! are preserved when packing.
decimalPrecision=2
call codes_set(igrib,"changeDecimalPrecision", &
decimalPrecision = 2
call codes_set(igrib, "changeDecimalPrecision", &
decimalPrecision)
! 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
call codes_get(igrib,"values",values2)
call codes_get(igrib, "values", values2)
! computing error
maxa=0
maxr=0
maxv=values2(1)
minv=maxv
do i=1,size1
a=abs(values2(i)-values1(i))
if ( values2(i) .gt. maxv ) maxv=values2(i)
if ( values2(i) .lt. maxv ) minv=values2(i)
if ( values2(i) .ne. 0 ) then
r=abs((values2(i)-values1(i))/values2(i))
endif
if ( a .gt. maxa ) maxa=a
if ( r .gt. maxr ) maxr=r
enddo
write(*,*) "max absolute error = ",maxa
write(*,*) "max relative error = ",maxr
write(*,*) "min value = ",minv
write(*,*) "max value = ",maxv
maxa = 0
maxr = 0
maxv = values2(1)
minv = maxv
do i = 1, size1
a = abs(values2(i) - values1(i))
if (values2(i) .gt. maxv) maxv = values2(i)
if (values2(i) .lt. maxv) minv = values2(i)
if (values2(i) .ne. 0) then
r = abs((values2(i) - values1(i))/values2(i))
end if
if (a .gt. maxa) maxa = a
if (r .gt. maxr) maxr = r
end do
write (*, *) "max absolute error = ", maxa
write (*, *) "max relative error = ", maxr
write (*, *) "min value = ", minv
write (*, *) "max value = ", maxv
write(*,*) "old number of bits per value=",bitsPerValue1
write(*,*) "new number of bits per value=",bitsPerValue2
write (*, *) "old number of bits per value=", bitsPerValue1
write (*, *) "new number of bits per value=", bitsPerValue2
! write modified message to a file
call codes_write(igrib,outfile)
call codes_write(igrib, outfile)
call codes_release(igrib)
@ -89,7 +89,7 @@ program precision
call codes_close_file(outfile)
deallocate(values1)
deallocate(values2)
deallocate (values1)
deallocate (values2)
end program precision

56
examples/F90/grib_print_data.f90
View File

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

50
examples/F90/grib_print_data_static.f90
View File

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

40
examples/F90/grib_read_message.f90
View File

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

72
examples/F90/grib_samples.f90
View File

@ -15,11 +15,11 @@ program sample
implicit none
integer :: err
integer :: outfile, datafile
integer :: igribsample,igribclone,igribdata, size1
integer :: igribsample, igribclone, igribdata, size1
integer :: date1, startStep, endStep, table2Version, indicatorOfParameter
integer :: decimalPrecision
character(len=10) stepType
real(kind=8), dimension(:), allocatable :: v1,v2,v
real(kind=8), dimension(:), allocatable :: v1, v2, v
date1 = 20080104
startStep = 0
@ -35,61 +35,61 @@ program sample
! setting the environment variable ECCODES_SAMPLES_PATH
call codes_grib_new_from_samples(igribsample, "regular_latlon_surface.grib1")
call codes_open_file(outfile, 'f_out.samples.grib1','w')
call codes_open_file(datafile,'../../data/tp_ecmwf.grib','r')
call codes_open_file(outfile, 'f_out.samples.grib1', 'w')
call codes_open_file(datafile, '../../data/tp_ecmwf.grib', 'r')
call codes_grib_new_from_file(datafile,igribdata,err)
call codes_grib_new_from_file(datafile, igribdata, err)
call codes_get_size(igribdata,'values',size1)
allocate(v(size1))
allocate(v1(size1))
allocate(v2(size1))
call codes_get_size(igribdata, 'values', size1)
allocate (v(size1))
allocate (v1(size1))
allocate (v2(size1))
call codes_get(igribdata,'values',v)
call codes_get(igribdata, 'values', v)
v=v*1000.0 ! different units for the output grib
v1=v
v = v*1000.0 ! different units for the output grib
v1 = v
do while (err/=CODES_END_OF_FILE)
do while (err /= CODES_END_OF_FILE)
call codes_clone(igribsample,igribclone) ! clone sample before modifying it
call codes_clone(igribsample, igribclone) ! clone sample before modifying it
call codes_set(igribclone,'dataDate',date1)
call codes_set(igribclone,'table2Version',table2Version)
call codes_set(igribclone,'indicatorOfParameter',indicatorOfParameter)
call codes_set(igribclone, 'dataDate', date1)
call codes_set(igribclone, 'table2Version', table2Version)
call codes_set(igribclone, 'indicatorOfParameter', indicatorOfParameter)
call codes_set(igribclone,'stepType',stepType)
call codes_set(igribclone,'startStep',startStep)
call codes_set(igribclone,'endStep',endStep)
call codes_set(igribclone, 'stepType', stepType)
call codes_set(igribclone, 'startStep', startStep)
call codes_set(igribclone, 'endStep', endStep)
call codes_set(igribclone,'decimalPrecision',decimalPrecision)
call codes_set(igribclone, 'decimalPrecision', decimalPrecision)
call codes_set(igribclone,'values',v)
call codes_set(igribclone, 'values', v)
call codes_write(igribclone,outfile)
call codes_write(igribclone, outfile)
call codes_grib_new_from_file(datafile,igribdata,err)
call codes_grib_new_from_file(datafile, igribdata, err)
if (err==0) then
call codes_get(igribdata,'values',v2)
if (err == 0) then
call codes_get(igribdata, 'values', v2)
v2=v2*1000.0 ! different units for the output grib
v2 = v2*1000.0 ! different units for the output grib
v=v2-v1 ! accumulation from startStep to endStep
v = v2 - v1 ! accumulation from startStep to endStep
v1=v2 ! save previous step field
v1 = v2 ! save previous step field
startStep=startStep+12
endStep=endStep+12
startStep = startStep + 12
endStep = endStep + 12
endif
end if
enddo
end do
call codes_release(igribsample)
deallocate(v)
deallocate(v1)
deallocate(v2)
deallocate (v)
deallocate (v1)
deallocate (v2)
call codes_close_file(outfile)

32
examples/F90/grib_set_bitmap.f90
View File

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

20
examples/F90/grib_set_data.f90
View File

@ -23,7 +23,7 @@ program set_data
character(len=max_strsize) :: 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"
! Sample files are stored in the samples directory (use codes_info to
@ -35,17 +35,17 @@ program set_data
! will be the same as the sample GRIB.
! But if your data array has a different size, then specify the grid geometry
! (e.g. keys Ni, Nj etc) and set the correct number of data values
call codes_get_size(igrib,'values',numberOfValues)
call codes_get_size(igrib, 'values', numberOfValues)
allocate(values(numberOfValues), stat=iret)
allocate (values(numberOfValues), stat=iret)
d = 10e-8
e = d
cnt = 1
do i=1,numberOfValues
if (cnt>100) then
do i = 1, numberOfValues
if (cnt > 100) then
e = e*10
cnt=1
endif
cnt = 1
end if
values(i) = d
!print *, values(i)
d = d + e
@ -55,9 +55,9 @@ program set_data
call codes_set(igrib, 'bitsPerValue', 16)
! set data values
call codes_set(igrib,'values', values)
call codes_write(igrib,outfile)
call codes_set(igrib, 'values', values)
call codes_write(igrib, outfile)
call codes_release(igrib)
deallocate(values)
deallocate (values)
end program set_data

28
examples/F90/grib_set_gvc.f90
View File

@ -15,30 +15,30 @@
program set
use eccodes
implicit none
integer :: infile,outfile
integer :: infile, outfile
integer :: igrib
call codes_open_file(infile, '../../data/sample.grib2','r')
call codes_open_file(infile, '../../data/sample.grib2', 'r')
call codes_open_file(outfile, 'out_gvc.grib2','w')
call codes_open_file(outfile, 'out_gvc.grib2', 'w')
call codes_grib_new_from_file(infile,igrib)
call codes_grib_new_from_file(infile, igrib)
! Individual ensemble forecast
call codes_set(igrib,'productDefinitionTemplateNumber', 11)
call codes_set(igrib, 'productDefinitionTemplateNumber', 11)
! 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
call codes_set(igrib,'nlev', 12.21)
call codes_set(igrib,'numberOfVGridUsed', 13.55)
call codes_set(igrib, 'nlev', 12.21)
call codes_set(igrib, 'numberOfVGridUsed', 13.55)
! check integrity of GRIB message
call check_settings(igrib)
! write modified message to a file
call codes_write(igrib,outfile)
call codes_write(igrib, outfile)
call codes_release(igrib)
call codes_close_file(infile)
@ -47,21 +47,21 @@ program set
contains
!======================================
subroutine check_settings(gribid)
subroutine check_settings(gribid)
implicit none
integer, intent(in) :: gribid
integer(kind = 4) :: NV,typeOfFirstFixedSurface
integer(kind=4) :: NV, typeOfFirstFixedSurface
call codes_get(gribid,'NV', NV)
call codes_get(gribid, 'NV', NV)
if (NV /= 6) then
call codes_check(-2, 'NV_should_be_6', '')
end if
call codes_get(gribid,'typeOfFirstFixedSurface', typeOfFirstFixedSurface)
call codes_get(gribid, 'typeOfFirstFixedSurface', typeOfFirstFixedSurface)
if (typeOfFirstFixedSurface /= 150) then
call codes_check(-2, 'typeOfFirstFixedSurface_should_be_150', '')
end if
end subroutine check_settings
end subroutine check_settings
end program set

50
examples/F90/grib_set_keys.f90
View File

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

26
examples/F90/grib_set_missing.f90
View File

@ -15,36 +15,36 @@
program set
use eccodes
implicit none
integer :: infile,outfile
integer :: infile, outfile
integer :: igrib, Ni, is_missing
infile=5
outfile=6
infile = 5
outfile = 6
call codes_open_file(infile, &
'../../data/reduced_gaussian_pressure_level.grib2','r')
'../../data/reduced_gaussian_pressure_level.grib2', 'r')
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
! 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_missing(igrib,'scaleFactorOfFirstFixedSurface')
call codes_set_missing(igrib,'scaledValueOfFirstFixedSurface')
call codes_set(igrib, 'typeOfFirstFixedSurface', 'sfc')
call codes_set_missing(igrib, 'scaleFactorOfFirstFixedSurface')
call codes_set_missing(igrib, 'scaledValueOfFirstFixedSurface')
! See GRIB-490
call codes_get(igrib, 'Ni', Ni)
call codes_is_missing(igrib,'Ni',is_missing)
if ( is_missing == 0 ) then
call codes_is_missing(igrib, 'Ni', is_missing)
if (is_missing == 0) then
! Ni should be missing in gribs with Reduced Gaussian grids
call codes_check(-2, 'Ni_should_be_missing', '')
endif
end if
call codes_set(igrib, 'Ni', Ni)
call codes_write(igrib,outfile)
call codes_write(igrib, outfile)
call codes_release(igrib)
call codes_close_file(infile)
call codes_close_file(outfile)

16
examples/F90/grib_set_packing.f90
View File

@ -22,20 +22,20 @@ program set_packing
call getarg(1, packing_type)
call getarg(2, outfile_name)
call codes_open_file(outfile,outfile_name,'w')
call codes_open_file(outfile, outfile_name, 'w')
call codes_grib_new_from_samples(igrib, 'gg_sfc_grib2')
call codes_get_size(igrib,'values', numberOfValues)
allocate(values(numberOfValues), stat=iret)
call codes_get_size(igrib, 'values', numberOfValues)
allocate (values(numberOfValues), stat=iret)
d = 10e-6
e = d
cnt = 1
do i=1,numberOfValues
if (cnt>100) then
do i = 1, numberOfValues
if (cnt > 100) then
e = e*1.01
cnt=1
endif
cnt = 1
end if
values(i) = d
d = d + e
cnt = cnt + 1
@ -49,6 +49,6 @@ program set_packing
call codes_write(igrib, outfile)
call codes_release(igrib)
deallocate(values)
deallocate (values)
end program set_packing

34
examples/F90/grib_set_pv.f90
View File

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

42
examples/F90/iterator_fortran.f90
View File

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

30
examples/F90/keys_iterator_fortran.f90
View File

@ -16,51 +16,51 @@
program keys_iterator
use eccodes
implicit none
integer :: kiter,ifile,igrib,iret
integer :: kiter, ifile, igrib, iret
character(len=256) :: key
character(len=256) :: value
character(len=2048) :: all
integer :: len
integer :: grib_count
len=256
len = 256
ifile=5
ifile = 5
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.
call codes_grib_new_from_file(ifile,igrib)
call codes_grib_new_from_file(ifile, igrib)
do while (igrib .ne. -1)
grib_count=grib_count+1
write(*,'("-- GRIB N.",I4," --")') grib_count
grib_count = grib_count + 1
write (*, '("-- GRIB N.",I4," --")') grib_count
! valid name_spaces are ls and mars
call codes_keys_iterator_new(igrib,kiter,'ls')
call codes_keys_iterator_new(igrib, kiter, 'ls')
if (kiter .eq. -1) then
print *, 'invalid key iterator'
endif
end if
do
call codes_keys_iterator_next(kiter, iret)
if (iret .ne. CODES_SUCCESS) exit
call codes_keys_iterator_get_name(kiter,key)
call codes_keys_iterator_get_name(kiter, key)
call codes_get(igrib,key,value)
all='|'//trim(key)//'|'//' = '//'|'//trim(value)//'|'
write(*,*) trim(all)
call codes_get(igrib, key, value)
all = '|'//trim(key)//'|'//' = '//'|'//trim(value)//'|'
write (*, *) trim(all)
end do
call codes_keys_iterator_delete(kiter)
call codes_release(igrib)
call codes_grib_new_from_file(ifile,igrib, iret)
call codes_grib_new_from_file(ifile, igrib, iret)
end do
call codes_close_file(ifile)

34
examples/F90/multi_fortran.f90
View File

@ -18,10 +18,10 @@ program multi
implicit none
integer :: iret
integer(kind = 4) :: parameterCategory,parameterNumber,discipline
integer :: ifile,igrib
integer(kind=4) :: parameterCategory, parameterNumber, discipline
integer :: ifile, igrib
call codes_open_file(ifile, '../../data/multi.grib2','r')
call codes_open_file(ifile, '../../data/multi.grib2', 'r')
! turn on support for multi fields messages */
call codes_grib_multi_support_on()
@ -29,36 +29,36 @@ program multi
! turn off support for multi fields messages */
!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.
do while (igrib .ne. -1)
! get as a integer*4
call codes_get(igrib,'discipline',discipline)
write(*,*) 'discipline=',discipline
call codes_get(igrib, 'discipline', discipline)
write (*, *) 'discipline=', discipline
! get as a integer*4
call codes_get(igrib,'parameterCategory', &
call codes_get(igrib, 'parameterCategory', &
parameterCategory)
write(*,*) 'parameterCategory=',parameterCategory
write (*, *) 'parameterCategory=', parameterCategory
! get as a integer*4
call codes_get(igrib,'parameterNumber', &
call codes_get(igrib, '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
write(*,*) "-------- u -------"
endif
write (*, *) "-------- u -------"
end if
if (parameterNumber .eq. 3) then
write(*,*) "-------- v -------"
endif
endif
write (*, *) "-------- v -------"
end if
end if
call codes_release(igrib)
call codes_grib_new_from_file(ifile,igrib, iret)
call codes_grib_new_from_file(ifile, igrib, iret)
end do
call codes_close_file(ifile)

23
examples/F90/new_from_file.f90
View File

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

82
examples/F90/precision_fortran.f90
View File

@ -13,73 +13,73 @@
program precision
use eccodes
implicit none
integer(kind = 4) :: size
integer :: infile,outfile
integer(kind=4) :: size
integer :: infile, outfile
integer :: igrib
real(kind = 8), dimension(:), allocatable :: values1
real(kind = 8), dimension(:), allocatable :: values2
real(kind = 8) :: maxa,a,maxv,minv,maxr,r
integer( kind = 4) :: decimalPrecision,bitsPerValue1,bitsPerValue2
real(kind=8), dimension(:), allocatable :: values1
real(kind=8), dimension(:), allocatable :: values2
real(kind=8) :: maxa, a, maxv, minv, maxr, r
integer(kind=4) :: decimalPrecision, bitsPerValue1, bitsPerValue2
integer :: i, iret
call codes_open_file(infile, &
'../../data/regular_latlon_surface_constant.grib1','r')
'../../data/regular_latlon_surface_constant.grib1', 'r')
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
! 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
call codes_get(igrib,'bitsPerValue',bitsPerValue1)
call codes_get(igrib, 'bitsPerValue', bitsPerValue1)
! 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(values2(size), stat=iret)
allocate (values1(size), stat=iret)
allocate (values2(size), stat=iret)
! 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
! are preserved when packing.
decimalPrecision=2
call codes_set(igrib,"setDecimalPrecision", &
decimalPrecision = 2
call codes_set(igrib, "setDecimalPrecision", &
decimalPrecision)
! 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
call codes_get(igrib,"values",values2)
call codes_get(igrib, "values", values2)
! computing error
maxa=0
maxr=0
maxv=values2(1)
minv=maxv
do i=1,size
a=abs(values2(i)-values1(i))
if ( values2(i) .gt. maxv ) maxv=values2(i)
if ( values2(i) .lt. maxv ) minv=values2(i)
if ( values2(i) .ne. 0 ) then
r=abs((values2(i)-values1(i))/values2(i))
endif
if ( a .gt. maxa ) maxa=a
if ( r .gt. maxr ) maxr=r
enddo
write(*,*) "max absolute error = ",maxa
write(*,*) "max relative error = ",maxr
write(*,*) "min value = ",minv
write(*,*) "max value = ",maxv
maxa = 0
maxr = 0
maxv = values2(1)
minv = maxv
do i = 1, size
a = abs(values2(i) - values1(i))
if (values2(i) .gt. maxv) maxv = values2(i)
if (values2(i) .lt. maxv) minv = values2(i)
if (values2(i) .ne. 0) then
r = abs((values2(i) - values1(i))/values2(i))
end if
if (a .gt. maxa) maxa = a
if (r .gt. maxr) maxr = r
end do
write (*, *) "max absolute error = ", maxa
write (*, *) "max relative error = ", maxr
write (*, *) "min value = ", minv
write (*, *) "max value = ", maxv
write(*,*) "old number of bits per value=",bitsPerValue1
write(*,*) "new number of bits per value=",bitsPerValue2
write (*, *) "old number of bits per value=", bitsPerValue1
write (*, *) "new number of bits per value=", bitsPerValue2
! write modified message to a file
call codes_write(igrib,outfile)
call codes_write(igrib, outfile)
call codes_release(igrib)
@ -87,6 +87,6 @@ program precision
call codes_close_file(outfile)
deallocate(values1)
deallocate(values2)
deallocate (values1)
deallocate (values2)
end program precision

46
examples/F90/print_data_fortran.f90
View File

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

72
examples/F90/read_from_file.f90
View File

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

36
examples/F90/set_fortran.f90
View File

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

20
examples/F90/set_missing_fortran.f90
View File

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