ecearth3/sources/tm5mp/base/standard_name_table.f90

!
! Fortran module to read standard_name_table XML files.
!
! USAGE
!
!   use standard_name_table
!
!   type(T_Standard_Name_Table)  ::  xml_data
!
!   call standard_name_table_Init( xml_data, 'example.xml', status, lurep=5 )
!
!   call standard_name_table_Done( xml_data, status )
!
!   call standard_name_table_Write( xml_data, 'example-rewritten.xml', status, lurep=5 )
!
!
! HISTORY
!   Code generated by the "xmlf-reader" program based on the free available
!   "xml-fortran-1.00.tar.gz" package.
!   Arjo Segers
!   
!   23 Oct 2012 - P. Le Sager - bug fix in standard_name_table_Init
!

module standard_name_table

  use XMLF

  implicit none

  integer, private :: lurep_
  logical, private :: strict_


type T_CF_Entry
   character(len=256)                                :: id
   character(len=64)                                :: canonical_units
   character(len=16)                                :: grib
end type T_CF_Entry

type T_CF_Alias
   character(len=256)                                :: id
   character(len=256)                                :: entry_id
end type T_CF_Alias

type T_Standard_Name_Table
   integer                                         :: version_number
   character(len=64)                                :: last_modified
   character(len=256)                                :: institution
   character(len=256)                                :: contact
   type(T_CF_Entry), dimension(:), pointer         :: entry => null()
   type(T_CF_Alias), dimension(:), pointer         :: alias => null()
end type T_Standard_Name_Table


contains


! =======================================================================


! ***

subroutine read_xml_type_T_CF_Entry_array( &
      info, tag, endtag, attribs, noattribs, data, nodata, &
      dvar, has_dvar, status )
   type(XML_PARSE)                                   :: info
   character(len=*), intent(inout)                   :: tag
   logical, intent(inout)                            :: endtag
   character(len=*), dimension(:,:), intent(inout)   :: attribs
   integer, intent(inout)                            :: noattribs
   character(len=*), dimension(:), intent(inout)     :: data
   integer, intent(inout)                            :: nodata
   type(T_CF_Entry), dimension(:), pointer :: dvar
   logical, intent(inout)                            :: has_dvar
   integer, intent(out)                              :: status

   integer                                      :: newsize
   type(T_CF_Entry), dimension(:), pointer :: newvar

   newsize = size(dvar) + 1
   allocate( newvar(1:newsize) )
   newvar(1:newsize-1) = dvar
   deallocate( dvar )
   dvar => newvar

   call read_xml_type_T_CF_Entry( info, tag, endtag, attribs, noattribs, data, nodata, &
              dvar(newsize), has_dvar, status )

end subroutine read_xml_type_T_CF_Entry_array


! ***

subroutine read_xml_type_T_CF_Entry( info, starttag, endtag, attribs, noattribs, data, nodata, &
              dvar, has_dvar, status )
   type(XML_PARSE)                                 :: info
   character(len=*), intent(in)                    :: starttag
   logical, intent(inout)                          :: endtag
   character(len=*), dimension(:,:), intent(inout) :: attribs
   integer, intent(inout)                          :: noattribs
   character(len=*), dimension(:), intent(inout)   :: data
   integer, intent(inout)                          :: nodata
   type(T_CF_Entry), intent(inout)       :: dvar
   logical, intent(inout)                          :: has_dvar
   integer, intent(out)                            :: status

   integer                                         :: att_
   integer                                         :: noatt_
   logical                                         :: error
   logical                                         :: endtag_org
   character(len=80)                            :: tag
   logical                                         :: has_id
   logical                                         :: has_canonical_units
   logical                                         :: has_grib
   has_id                               = .false.
   has_canonical_units                  = .false.
   has_grib                             = .false.
   call init_xml_type_T_CF_Entry(dvar)
   has_dvar = .true.
   error  = .false.
   att_   = 0
   noatt_ = noattribs+1
   endtag_org = endtag
   do
      if ( nodata .ne. 0 ) then
         noattribs = 0
         tag = starttag
      elseif ( att_ .lt. noatt_ .and. noatt_ .gt. 1 ) then
         att_      = att_ + 1
         if ( att_ .le. noatt_-1 ) then
            tag       = attribs(1,att_)
            data(1)   = attribs(2,att_)
            noattribs = 0
            nodata    = 1
            endtag    = .false.
         else
            tag       = starttag
            noattribs = 0
            nodata    = 0
            endtag    = .true.
            cycle
         endif
      else
         if ( endtag_org ) then
            return
         else
            call xml_get( info, tag, endtag, attribs, noattribs, data, nodata )
            if ( xml_error(info) ) then
               write(lurep_,*) 'Error reading input file!'
               error = .true.
               status=1; return
            endif
         endif
      endif
      if ( endtag .and. tag .eq. starttag ) then
         exit
      endif
      if ( endtag .and. noattribs .eq. 0 ) then
         if ( xml_ok(info) ) then
            cycle
         else
            exit
         endif
      endif
      select case( tag )
      case('id')
         call read_xml_line( &
            info, tag, endtag, attribs, noattribs, data, nodata, &
            dvar%id, has_id, status )
      case('canonical_units')
         call read_xml_line( &
            info, tag, endtag, attribs, noattribs, data, nodata, &
            dvar%canonical_units, has_canonical_units, status )
      case('grib')
         call read_xml_line( &
            info, tag, endtag, attribs, noattribs, data, nodata, &
            dvar%grib, has_grib, status )
      case ('comment', '!--')
         ! Simply ignore
      case default
         if ( strict_ ) then
            error = .true.
            call xml_report_errors( info, &
               'Unknown or wrongly placed tag: ' // trim(tag))
         endif
      end select
      nodata = 0
      if ( .not. xml_ok(info) ) exit
   end do
   if ( .not. has_id ) then
      has_dvar = .false.
      call xml_report_errors(info, 'Missing data on id')
   endif
   if ( .not. has_canonical_units ) then
      has_dvar = .false.
      call xml_report_errors(info, 'Missing data on canonical_units')
   endif
end subroutine read_xml_type_T_CF_Entry

! ***

subroutine init_xml_type_T_CF_Entry_array( dvar )
   type(T_CF_Entry), dimension(:), pointer :: dvar
   if ( associated( dvar ) ) then
      deallocate( dvar )
   endif
   allocate( dvar(0) )
end subroutine init_xml_type_T_CF_Entry_array

! ***

subroutine init_xml_type_T_CF_Entry(dvar)
   type(T_CF_Entry) :: dvar
   dvar%grib = ''
end subroutine init_xml_type_T_CF_Entry

! ***

subroutine write_xml_type_T_CF_Entry_array( &
      info, tag, indent, dvar )
   type(XML_PARSE)                                 :: info
   character(len=*), intent(in)                    :: tag
   integer                                         :: indent
   type(T_CF_Entry), dimension(:)        :: dvar
   integer                                         :: i
   do i = 1,size(dvar)
       call write_xml_type_T_CF_Entry( info, tag, indent, dvar(i) )
   enddo
end subroutine write_xml_type_T_CF_Entry_array

! ***

subroutine write_xml_type_T_CF_Entry( &
      info, tag, indent, dvar )
   type(XML_PARSE)                                 :: info
   character(len=*), intent(in)                    :: tag
   integer                                         :: indent
   type(T_CF_Entry)                      :: dvar
   character(len=100)                              :: indentation
   indentation = ' '
   write(info%lun, '(4a)' ) indentation(1:min(indent,100)),&
       '<',trim(tag), '>'
   call write_to_xml_line( info, 'id', indent+3, dvar%id)
   call write_to_xml_line( info, 'canonical_units', indent+3, dvar%canonical_units)
   call write_to_xml_line( info, 'grib', indent+3, dvar%grib)
   write(info%lun,'(4a)') indentation(1:min(indent,100)), &
       '</' //trim(tag) // '>'
end subroutine write_xml_type_T_CF_Entry


! ***

subroutine read_xml_type_T_CF_Alias_array( &
      info, tag, endtag, attribs, noattribs, data, nodata, &
      dvar, has_dvar, status )
   type(XML_PARSE)                                   :: info
   character(len=*), intent(inout)                   :: tag
   logical, intent(inout)                            :: endtag
   character(len=*), dimension(:,:), intent(inout)   :: attribs
   integer, intent(inout)                            :: noattribs
   character(len=*), dimension(:), intent(inout)     :: data
   integer, intent(inout)                            :: nodata
   type(T_CF_Alias), dimension(:), pointer :: dvar
   logical, intent(inout)                            :: has_dvar
   integer, intent(out)                              :: status

   integer                                      :: newsize
   type(T_CF_Alias), dimension(:), pointer :: newvar

   newsize = size(dvar) + 1
   allocate( newvar(1:newsize) )
   newvar(1:newsize-1) = dvar
   deallocate( dvar )
   dvar => newvar

   call read_xml_type_T_CF_Alias( info, tag, endtag, attribs, noattribs, data, nodata, &
              dvar(newsize), has_dvar, status )

end subroutine read_xml_type_T_CF_Alias_array


! ***

subroutine read_xml_type_T_CF_Alias( info, starttag, endtag, attribs, noattribs, data, nodata, &
              dvar, has_dvar, status )
   type(XML_PARSE)                                 :: info
   character(len=*), intent(in)                    :: starttag
   logical, intent(inout)                          :: endtag
   character(len=*), dimension(:,:), intent(inout) :: attribs
   integer, intent(inout)                          :: noattribs
   character(len=*), dimension(:), intent(inout)   :: data
   integer, intent(inout)                          :: nodata
   type(T_CF_Alias), intent(inout)       :: dvar
   logical, intent(inout)                          :: has_dvar
   integer, intent(out)                            :: status

   integer                                         :: att_
   integer                                         :: noatt_
   logical                                         :: error
   logical                                         :: endtag_org
   character(len=80)                            :: tag
   logical                                         :: has_id
   logical                                         :: has_entry_id
   has_id                               = .false.
   has_entry_id                         = .false.
   call init_xml_type_T_CF_Alias(dvar)
   has_dvar = .true.
   error  = .false.
   att_   = 0
   noatt_ = noattribs+1
   endtag_org = endtag
   do
      if ( nodata .ne. 0 ) then
         noattribs = 0
         tag = starttag
      elseif ( att_ .lt. noatt_ .and. noatt_ .gt. 1 ) then
         att_      = att_ + 1
         if ( att_ .le. noatt_-1 ) then
            tag       = attribs(1,att_)
            data(1)   = attribs(2,att_)
            noattribs = 0
            nodata    = 1
            endtag    = .false.
         else
            tag       = starttag
            noattribs = 0
            nodata    = 0
            endtag    = .true.
            cycle
         endif
      else
         if ( endtag_org ) then
            return
         else
            call xml_get( info, tag, endtag, attribs, noattribs, data, nodata )
            if ( xml_error(info) ) then
               write(lurep_,*) 'Error reading input file!'
               error = .true.
               status=1; return
            endif
         endif
      endif
      if ( endtag .and. tag .eq. starttag ) then
         exit
      endif
      if ( endtag .and. noattribs .eq. 0 ) then
         if ( xml_ok(info) ) then
            cycle
         else
            exit
         endif
      endif
      select case( tag )
      case('id')
         call read_xml_line( &
            info, tag, endtag, attribs, noattribs, data, nodata, &
            dvar%id, has_id, status )
      case('entry_id')
         call read_xml_line( &
            info, tag, endtag, attribs, noattribs, data, nodata, &
            dvar%entry_id, has_entry_id, status )
      case ('comment', '!--')
         ! Simply ignore
      case default
         if ( strict_ ) then
            error = .true.
            call xml_report_errors( info, &
               'Unknown or wrongly placed tag: ' // trim(tag))
         endif
      end select
      nodata = 0
      if ( .not. xml_ok(info) ) exit
   end do
   if ( .not. has_id ) then
      has_dvar = .false.
      call xml_report_errors(info, 'Missing data on id')
   endif
   if ( .not. has_entry_id ) then
      has_dvar = .false.
      call xml_report_errors(info, 'Missing data on entry_id')
   endif
end subroutine read_xml_type_T_CF_Alias

! ***

subroutine init_xml_type_T_CF_Alias_array( dvar )
   type(T_CF_Alias), dimension(:), pointer :: dvar
   if ( associated( dvar ) ) then
      deallocate( dvar )
   endif
   allocate( dvar(0) )
end subroutine init_xml_type_T_CF_Alias_array

! ***

subroutine init_xml_type_T_CF_Alias(dvar)
   type(T_CF_Alias) :: dvar
end subroutine init_xml_type_T_CF_Alias

! ***

subroutine write_xml_type_T_CF_Alias_array( &
      info, tag, indent, dvar )
   type(XML_PARSE)                                 :: info
   character(len=*), intent(in)                    :: tag
   integer                                         :: indent
   type(T_CF_Alias), dimension(:)        :: dvar
   integer                                         :: i
   do i = 1,size(dvar)
       call write_xml_type_T_CF_Alias( info, tag, indent, dvar(i) )
   enddo
end subroutine write_xml_type_T_CF_Alias_array

! ***

subroutine write_xml_type_T_CF_Alias( &
      info, tag, indent, dvar )
   type(XML_PARSE)                                 :: info
   character(len=*), intent(in)                    :: tag
   integer                                         :: indent
   type(T_CF_Alias)                      :: dvar
   character(len=100)                              :: indentation
   indentation = ' '
   write(info%lun, '(4a)' ) indentation(1:min(indent,100)),&
       '<',trim(tag), '>'
   call write_to_xml_line( info, 'id', indent+3, dvar%id)
   call write_to_xml_line( info, 'entry_id', indent+3, dvar%entry_id)
   write(info%lun,'(4a)') indentation(1:min(indent,100)), &
       '</' //trim(tag) // '>'
end subroutine write_xml_type_T_CF_Alias


! ***


subroutine standard_name_table_Init( gvar, fname, status, lurep )

   ! --- in/out ---------------------------------------------------

   type(T_Standard_Name_Table), intent(out)             ::  gvar
   character(len=*), intent(in)           :: fname
   integer, intent(out)                   :: status
   integer, intent(in), optional          :: lurep

   ! --- local ---------------------------------------------------

   type(XML_PARSE)                        :: info
   logical                                :: error
   character(len=80)                      :: tag
   character(len=80)                      :: starttag
   logical                                :: endtag
   character(len=80), dimension(1:2,1:20) :: attribs
   integer                                :: noattribs
   character(len=200), dimension(1:100)   :: data
   integer                                :: nodata
   logical                                         :: has_version_number
   logical                                         :: has_last_modified
   logical                                         :: has_institution
   logical                                         :: has_contact
   logical                                         :: has_entry
   logical                                         :: has_alias
   has_version_number                   = .false.
   has_last_modified                    = .false.
   has_institution                      = .false.
   has_contact                          = .false.
   has_entry                            = .false.
   allocate(gvar%entry(0))
   has_alias                            = .false.
   allocate(gvar%alias(0))

   call init_xml_file_standard_name_table()

! Prior 23-10-2012 (PLS: moved below, after xml_open to avoid bad initialization)
!   call xml_options( info, report_errors=.true., ignore_whitespace=.true.)
!   if (info%error) then; status=1; return; end if

   call xml_open( info, fname, .true. )
   if (info%error) then; status=1; return; end if
      
! After 23-10-2012 (PLS: moved here, after xml_open to avoid bad initialization)
   call xml_options( info, report_errors=.true., ignore_whitespace=.true.)
   if (info%error) then; status=1; return; end if
      
   lurep_ = 0
   if ( present(lurep) ) then
      lurep_ = lurep
      call xml_options( info, report_lun=lurep )
   endif
   do
      call xml_get( info, starttag, endtag, attribs, noattribs, &
         data, nodata)
      if ( starttag .ne. '!--' ) exit
   enddo
   if ( starttag .ne. "standard_name_table" ) then
      call xml_report_errors( info, &
         'XML-file should have root element "standard_name_table"')
      error = .true.
      call xml_close(info)
      status=1; return
   endif
   strict_ = .false.
   error = .false.
   do
      call xml_get( info, tag, endtag, attribs, noattribs, data, nodata )
      if ( xml_error(info) ) then
         write(lurep_,*) 'Error reading input file!'
         error = .true.
         status=1; return
      endif
      if ( endtag .and. tag .eq. starttag ) then
         exit
      endif
      if ( endtag .and. noattribs .eq. 0 ) then
         if ( xml_ok(info) ) then
            cycle
         else
            exit
         endif
      endif
      select case( tag )
      case('version_number')
         call read_xml_integer( &
            info, tag, endtag, attribs, noattribs, data, nodata, &
            gvar%version_number, has_version_number, status )
      case('last_modified')
         call read_xml_line( &
            info, tag, endtag, attribs, noattribs, data, nodata, &
            gvar%last_modified, has_last_modified, status )
      case('institution')
         call read_xml_line( &
            info, tag, endtag, attribs, noattribs, data, nodata, &
            gvar%institution, has_institution, status )
      case('contact')
         call read_xml_line( &
            info, tag, endtag, attribs, noattribs, data, nodata, &
            gvar%contact, has_contact, status )
      case('entry')
         call read_xml_type_T_CF_Entry_array( &
            info, tag, endtag, attribs, noattribs, data, nodata, &
            gvar%entry, has_entry, status )
      case('alias')
         call read_xml_type_T_CF_Alias_array( &
            info, tag, endtag, attribs, noattribs, data, nodata, &
            gvar%alias, has_alias, status )
      case ('comment', '!--')
         ! Simply ignore
      case default
         if ( strict_ ) then
            error = .true.
            call xml_report_errors( info, &
               'Unknown or wrongly placed tag: ' // trim(tag))
         endif
      end select
      nodata = 0
      if ( .not. xml_ok(info) ) exit
   end do
   if ( .not. has_version_number ) then
      error = .true.
      call xml_report_errors(info, 'Missing data on version_number')
   endif
   if ( .not. has_last_modified ) then
      error = .true.
      call xml_report_errors(info, 'Missing data on last_modified')
   endif
   if ( .not. has_institution ) then
      error = .true.
      call xml_report_errors(info, 'Missing data on institution')
   endif
   if ( .not. has_contact ) then
      error = .true.
      call xml_report_errors(info, 'Missing data on contact')
   endif
   if ( .not. has_entry ) then
      error = .true.
      call xml_report_errors(info, 'Missing data on entry')
   endif
   if ( .not. has_alias ) then
      error = .true.
      call xml_report_errors(info, 'Missing data on alias')
   endif

   ! set return code:
   status = 0
   if ( error ) status = -1

end subroutine


! ***


subroutine standard_name_table_Done( gvar, status )

   ! --- in/out ---------------------------------------------------

   type(T_Standard_Name_Table), intent(inout)    ::  gvar
   integer, intent(out)                   :: status

   ! --- local ---------------------------------------------------

   if ( associated(gvar%entry) ) deallocate( gvar%entry )
   if ( associated(gvar%alias) ) deallocate( gvar%alias )

   ! ok:
   status = 0

end subroutine


! ***


subroutine standard_name_table_Write( gvar, fname, status, lurep )

   ! --- in/out ---------------------------------------------------

   type(T_Standard_Name_Table), intent(in)             ::  gvar
   character(len=*), intent(in)           :: fname
   integer, intent(out)                   :: status
   integer, intent(in), optional          :: lurep

   ! --- local ---------------------------------------------------

   type(XML_PARSE)                        :: info
   integer                                :: indent = 0

   ! --- in/out ---------------------------------------------------

   call xml_open( info, fname, .false. )
   call xml_options( info, report_errors=.true.)
   if ( present(lurep) ) then
       call xml_options( info, report_errors=.true.)
   endif
   write(info%lun,'(a)') &
      '<standard_name_table>'
   call write_to_xml_integer( info, 'version_number', indent+3, gvar%version_number)
   call write_to_xml_line( info, 'last_modified', indent+3, gvar%last_modified)
   call write_to_xml_line( info, 'institution', indent+3, gvar%institution)
   call write_to_xml_line( info, 'contact', indent+3, gvar%contact)
   call write_xml_type_T_CF_Entry_array( info, 'entry', indent+3, gvar%entry)
   call write_xml_type_T_CF_Alias_array( info, 'alias', indent+3, gvar%alias)
   write(info%lun,'(a)') '</standard_name_table>'
   call xml_close(info)

   ! ok
   status = 0

end subroutine


! ***

subroutine init_xml_file_standard_name_table

end subroutine

end module