g2cf.F90

Go to the documentation of this file.

 
 
module g2cf
  use g2c_interface
 
  integer, parameter :: g2_noerr = 0
 
  integer, parameter :: g2_max_name = 1024
 
  integer, parameter :: g2_max_pds_template_len = 50
 
  integer, parameter :: g2_max_gds_template_len = 50
 
  integer, parameter :: g2_max_drs_template_len = 55
 
contains
  function addcnullchar(string, nlen) result(cstring)
    use iso_c_binding
    implicit none
 
    character(len=*), intent(in)    :: string
    integer,          intent(inout) :: nlen
    character(len = (len(string) + 1))  :: cstring
 
    integer :: inull
 
    ! First check to see if we already have a C NULL char attached
    ! to string and strip trailing blanks. We will use it if its present 
    ! otherwise we add one. The length of the trimmed string plus the
    ! C_NULL_CHAR is returned in nlen.
    nlen  = len_trim(string)
    inull = scan(string, c_null_char)
    cstring = repeat(" ", len(cstring)) ! init to blanks
    if (inull > 0)  then ! string has a NULL char
       nlen = inull
       cstring = string(1:nlen)
    else ! append null char to trimmed string
       cstring = string(1:nlen)//c_null_char
       nlen = nlen + 1
    endif
  end function addcnullchar
 
  function stripcnullchar(cstring, nlen) result(string)
    use iso_c_binding    
    implicit none
 
    character(len=*), intent(in) :: cstring
    integer,          intent(in) :: nlen
    character(len=nlen)          :: string
    integer :: ie, inull
 
    ie = len_trim(cstring)
    inull = scan(cstring, c_null_char)
 
    if (inull > 1) ie = inull-1
    ie = max(1, min(ie, nlen)) ! limit ie to 1 or nlen
    string       = repeat(" ", nlen)
    string(1:ie) = cstring(1:ie)
 
  end function stripcnullchar
  
  function g2cf_open(path, mode, g2id) result (status)
    use iso_c_binding
    use g2c_interface
    implicit none
    
    character(len = *), intent(in) :: path
    integer, intent(in) :: mode
    integer, intent(inout) :: g2id
    integer :: status
 
    integer(c_int) :: cmode, cg2id, cstatus
    character(len = (len(path) + 1)) :: cpath
    integer :: ie
    
    cmode = mode
    cg2id = 0
    
    ! Check for C null character on path and add one if not present.
    cpath = addcnullchar(path, ie) 
    
    ! Call g2c_open to open GRIB2 file.
    cstatus = g2c_open(cpath(1:ie), cmode, cg2id)
 
    ! Return results to caller.
    if (cstatus .eq. 0) then
       g2id = cg2id
    endif
    status = cstatus
 
  end function g2cf_open
 
  function g2cf_open_index(data_file, index_file, mode, g2cid) result (status)
    use iso_c_binding
    implicit none
    
    character(len=*), intent(in) :: data_file, index_file
    integer, intent(in) :: mode
    integer, intent(inout) :: g2cid
    integer :: status
    
    integer(c_int) :: cmode, cg2cid, cstatus
    character(len = (len(data_file) + 1)) :: cdata_file
    character(len = (len(index_file) + 1)) :: cindex_file
    integer :: ie1, ie2
    
    cmode = mode
    cg2cid = 0
    
    ! Check for c null character on path and add one if not present.
    cdata_file = addcnullchar(data_file, ie1)
    cindex_file = addcnullchar(index_file, ie2)
    
    ! Call g2c_open_index to open the file.
    cstatus = g2c_open_index(cdata_file(1:ie1), cindex_file(1:ie2), cmode, cg2cid)
    
    if (cstatus == 0) then
       g2cid   = cg2cid
    endif
    status = cstatus
  end function g2cf_open_index
 
  function g2cf_inq(g2id, num_msg) result(status)
    use iso_c_binding    
    use g2c_interface
    implicit none
    
    integer, intent(in) :: g2id
    integer, intent(out) :: num_msg    
    integer :: status
    
    integer(c_int) :: cg2id, cnum_msg, cstatus
 
    cg2id = g2id
    cstatus = g2c_inq(cg2id, cnum_msg)
    num_msg = cnum_msg
    status = cstatus
  end function g2cf_inq
 
  function g2cf_inq_msg(g2id, msg_num, discipline, num_fields, &
          num_local, center, subcenter, master_version, local_version) result(status)
    use iso_c_binding    
    use g2c_interface
    implicit none
    
    integer, intent(in) :: g2id, msg_num
    integer(kind = 1), intent(out) :: discipline
    integer, intent(out) :: num_fields, num_local
    integer(kind = 2), intent(out) :: center, subcenter
    integer(kind = 1), intent(out) :: master_version, local_version
    integer :: status
 
    integer(c_int) :: cg2id, cmsg_num, cstatus
    integer(c_signed_char) :: cdiscipline
    integer(c_int) :: cnum_fields, cnum_local
    integer(c_short) :: ccenter, csubcenter
    integer(c_signed_char) :: cmaster_version, clocal_version
 
    cg2id = g2id
    ! Subtract 1 because C is zero-based.
    cmsg_num = msg_num - 1 
    cstatus = g2c_inq_msg(cg2id, cmsg_num, cdiscipline, cnum_fields, &
         cnum_local, ccenter, csubcenter, cmaster_version, clocal_version)
    discipline = cdiscipline
    num_fields = cnum_fields
    num_local = cnum_local
    center = ccenter
    subcenter = csubcenter
    master_version = cmaster_version
    local_version = clocal_version
    status = cstatus
  end function g2cf_inq_msg
 
  function g2cf_inq_msg_time(g2id, msg_num, sig_ref_time, year, &
       month, day, hour, minute, second) result(status)
    use iso_c_binding    
    use g2c_interface
    implicit none
 
    integer, intent(in) :: g2id
    integer, intent(in) :: msg_num
    integer(kind = 1), intent(out) :: sig_ref_time
    integer(kind = 2), intent(out) :: year
    integer(kind = 1), intent(out) :: month, day, hour, minute, second
 
    integer(c_int) :: g2cid, cmsg_num
    integer(c_signed_char) :: csig_ref_time
    integer(c_short) :: cyear
    integer(c_signed_char) :: cmonth, cday, chour, cminute, csecond
 
    integer(c_int) :: cstatus
    integer :: status
 
    g2cid = g2id
    cmsg_num = msg_num - 1 ! C is 0-based.
    cstatus = g2c_inq_msg_time(g2id, cmsg_num, csig_ref_time, cyear, &
         cmonth, cday, chour, cminute, csecond)
    sig_ref_time = csig_ref_time
    year = cyear
    month = cmonth
    day = cday
    hour = chour
    minute = cminute
    second = csecond
    status = cstatus    
    
  end function g2cf_inq_msg_time
 
  function g2cf_inq_prod(g2id, msg_num, prod_num, pds_template_len, pds_template, gds_template_len, &
       gds_template, drs_template_len, drs_template) result(status)
    use iso_c_binding    
    use g2c_interface
    implicit none
 
    integer, intent(in) :: g2id, msg_num, prod_num
    integer, intent(out) :: pds_template_len
    integer(kind = 8), intent(out) :: pds_template(*)
    integer, intent(out) :: gds_template_len
    integer(kind = 8), intent(out) :: gds_template(*)
    integer, intent(out) :: drs_template_len
    integer(kind = 8), intent(out) :: drs_template(*)
 
    integer(c_int) :: g2cid, cmsg_num
    integer(c_int) :: cprod_num, cpds_template_len
    integer(c_long_long) :: cpds_template(g2_max_pds_template_len)
    integer(c_int) :: cgds_template_len
    integer(c_long_long) :: cgds_template(g2_max_gds_template_len)
    integer(c_int) :: cdrs_template_len
    integer(c_long_long) :: cdrs_template(g2_max_drs_template_len)
 
    integer(c_int) :: cstatus
    integer :: status, i
 
    ! Copy input params to C types.
    g2cid = g2id
    cmsg_num = msg_num - 1 ! C is 0-based.
    cprod_num = prod_num - 1 ! C is 0-based.
 
    ! Call the C function.
    cstatus = g2c_inq_prod(g2cid, cmsg_num, cprod_num, cpds_template_len, cpds_template, &
         cgds_template_len, cgds_template, cdrs_template_len, cdrs_template)
 
    ! Copy output params to Fortran types.
    pds_template_len = cpds_template_len
    if (pds_template_len .gt. 0) then
       do i = 1, pds_template_len
          pds_template(i) = cpds_template(i)
       end do
    endif
    gds_template_len = cgds_template_len
    if (gds_template_len .gt. 0) then
       do i = 1, gds_template_len
          gds_template(i) = cgds_template(i)
       end do
    endif
    drs_template_len = cdrs_template_len
    if (drs_template_len .gt. 0) then
       do i = 1, drs_template_len
          drs_template(i) = cdrs_template(i)
       end do
    endif
    status = cstatus
    
  end function g2cf_inq_prod
 
  function g2cf_inq_dim(g2id, msg_num, prod_num, dim_num, dimlen, name, val) result(status)
    use iso_c_binding    
    use g2c_interface
    implicit none
 
    integer, intent(in) :: g2id, msg_num, prod_num, dim_num
    integer(kind = 8), intent(out) :: dimlen
    character, intent(out)  :: name(*)
    real, intent(out), optional :: val(*)
       
    integer(c_int) :: g2cid, cmsg_num, cprod_num, cdim_num
    integer(c_size_t) :: cdimlen
    real(c_float) :: cval(10)
 
    character(len = G2_MAX_NAME) :: tmpname 
    integer(kind = 8) :: i
    integer :: nlen
    integer(c_int) :: cstatus
    integer :: status
 
    ! Copy input params to C types.
    g2cid = g2id
    cmsg_num = msg_num - 1 ! C is 0-based.
    cprod_num = prod_num - 1 ! C is 0-based.
    cdim_num = dim_num - 1 ! C is 0-based.
    nlen = len(name)
 
    ! Call the C function.
    if (present(val)) then
       cstatus = g2c_inq_dim(g2cid, cmsg_num, cprod_num, cdim_num, cdimlen, &
            tmpname, cval)
    else
       cstatus = g2c_inq_dim_info(g2cid, cmsg_num, cprod_num, cdim_num, cdimlen, &
            tmpname)
    endif
 
    ! Copy output params to Fortran types.
    if (cstatus == g2_noerr) then
       dimlen = cdimlen
       ! Strip c null char from tmpname if present and set end of string.
       name(:nlen) = stripcnullchar(tmpname, nlen)
 
       ! Copy values.
       if (present(val)) then
          do i = 1, dimlen
             val(i) = cval(i)
          end do
       endif
    endif
 
    ! Copy exit status.
    status = cstatus
    
  end function g2cf_inq_dim
 
     ! /* Getting data. */
     ! int g2c_get_prod(int g2cid, int msg_num, int prod_num, int *num_data_points,
     !                  float *data);
     ! function g2c_get_prod(g2id, msg_num, prod_num, num_data_points, data) bind(c)
     !   use iso_c_binding
     !   integer(c_int), value :: g2id
     !   integer(c_int), value :: msg_num
     !   integer(c_int), value :: prod_num
     !   integer(c_int), intent(out) :: num_data_points
     !   real(c_float), intent(out) :: data
     !   integer(c_int) :: g2c_get_prod
     ! end function g2c_get_prod
  function g2cf_close(g2id) result(status)
    use iso_c_binding    
    use g2c_interface
    implicit none
    
    integer, intent(in) :: g2id
    integer :: status
    
    integer(c_int) :: cg2id, cstatus
 
    cg2id = g2id
    cstatus = g2c_close(cg2id)
    status = cstatus
  end function g2cf_close
 
  function g2cf_set_log_level(log_level) result(status)
    use iso_c_binding    
    use g2c_interface
    implicit none
    
    integer, intent(in) :: log_level
    integer :: status
    
    integer(c_int) :: clog_level, cstatus
 
    clog_level = log_level
    cstatus = g2c_set_log_level(clog_level)
    status = cstatus
  end function g2cf_set_log_level
  
end module g2cf