ecearth3/sources/tm5mp/base/grib_table.F90

!### macro's #####################################################
!
#define TRACEBACK write (gol,'("in ",a," (",a,", line",i5,")")') rname, __FILE__, __LINE__; call goErr
#define IF_NOTOK_RETURN(action) if (status/=0) then; TRACEBACK; action; return; end if
#define IF_ERROR_RETURN(action) if (status> 0) then; TRACEBACK; action; return; end if
!
#include "tmm.inc"
!
!#################################################################

module grib_table

  implicit none
  
  ! --- in/out -----------------------------------
  
  private
  
  public    ::  GetPid
  public    ::  GetPidName
  
  
  ! --- const ------------------------------
  
  character(len=*), parameter  ::  mname = 'grib_table'
  


contains


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


  subroutine GetPid( table, key, pid, tabid, status )
  
    use GO, only : gol, goErr
  
    ! --- in/out --------------------------------
  
    character(len=*), intent(in)        ::  table
    character(len=*), intent(in)        ::  key
    integer, intent(out)                ::  pid
    integer, intent(out)                ::  tabid
    integer, intent(out)                ::  status
    
    ! --- const --------------------------------------
    
    character(len=*), parameter  ::  rname = mname//'/GetPid'
    
    ! --- local ----------------------------------
    
    integer     ::  tabv
    
    ! --- begin ----------------------------------
    
    ! default table version:
    tabid = 128

    select case ( table )
    
      ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      ! ECMWF codes
      ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      case ( 'ec' )
      
        select case ( key )

          case ( 'CVL' , 'cvl'  ); pid = 027   ! low  vegetation cover
          case ( 'CVH' , 'cvh'  ); pid = 028   ! high vegetation cover
          case ( 'TVL' , 'tvl'  ); pid = 029   ! type of low  vegetation
          case ( 'TVH' , 'tvh'  ); pid = 030   ! type of high vegetation

          case ( 'CI'  , 'ci'   ); pid = 031   ! sea-ice cover
          case ( 'SSTK', 'sstk', 'sst' ); pid = 034   ! sea surface temperature

          case ( 'SWV1', 'swv1', 'swvl1' ); pid = 039   ! volumetric soil water layer 1
          case ( 'SWV2', 'swv2', 'swvl2' ); pid = 040   ! volumetric soil water layer 2
          case ( 'SWV3', 'swv3', 'swvl3' ); pid = 041   ! volumetric soil water layer 3
          case ( 'SWV4', 'swv4', 'swvl4' ); pid = 042   ! volumetric soil water layer 4

          case ( 'STL1', 'stl1' ); pid = 139   ! soil temperature layer 1

          case ( 'G10M',  'g10m'  ); pid = 049            ! wind gust at 10m (Need to account for the following two lines)
          case ( '10FG',  '10fg'  ); pid = 049            ! wind gust at 10m 3-HOURLY (before cycle 37r3) and HOURLY accumulation (after cycle 37r3)
          case ( '10FG3', '10fg3' ); pid = 028; tabid=228 ! wind gust at 10m 3-HOURLY accumulation (from cycle 37r3)

          case ( 'PV'           ); pid =  60   ! potential vorticity (K m2/kg/s)

          ! era40, local table 162
          ! NOTE: for era2004 set, local table in grib files is actually 128 (error!)
          case ( 'UDMF'       ); pid = 104; tabid = 162   !    updraught mass flux           [kg/m2]
          case ( 'DDMF'       ); pid = 105; tabid = 162   !  downdraught mass flux           [kg/m2]
          case ( 'UDDR'       ); pid = 106; tabid = 162   !    updraught detrainment rate    [kg/m3]
          case ( 'DDDR'       ); pid = 107; tabid = 162   !  downdraught detrainment rate    [kg/m3]
          case ( 'K', 'TDCHA' ); pid = 109; tabid = 162   ! turbulent diff. coeff. for heat  [m2]
          
          ! era5:
          case ( 'MUMF' ); pid = 009; tabid = 235   ! mean   updraught mass flux              [kg/m2/s] aver prev hour
          case ( 'MDMF' ); pid = 010; tabid = 235   ! mean downdraught mass flux              [kg/m2/s] aver prev hour
          case ( 'MUDR' ); pid = 011; tabid = 235   ! mean   updraught detrainment rate       [kg/m3/s] aver prev hour
          case ( 'MDDR' ); pid = 012; tabid = 235   ! mean downdraught detrainment rate       [kg/m3/s] aver prev hour
          case ( 'MTDCH'); pid = 014; tabid = 235   ! mean turbulent diff. coeff. for heat    [m2/s   ] aver prev hour

          case ( 'U'            ); pid = 131   ! u wind
          case ( 'V'            ); pid = 132   ! v wind

          case ( 'Z'            ); pid = 129   ! geopotential, orography at surface
          case ( 'oro'          ); pid = 129   ! orography (geopotential at surface)
          case ( 'T'            ); pid = 130   ! temperature
          case ( 'Q'            ); pid = 133   ! specific humidity
          case ( 'SP'  , 'sp'   ); pid = 134
          case ( 'W'            ); pid = 135
          case ( 'VO'           ); pid = 138

          case ( 'SLW' , 'slw'  ); pid = 140
          case ( 'SD'  , 'sd'   ); pid = 141
#ifdef with_ec_aver
          case ( 'MLSPR'   , 'mlspr'    ); pid = 029; tabid = 235  ! Mean large-scale precipitation rate              kg m-2 s-1
          case ( 'MCPR'    , 'mcpr'     ); pid = 030; tabid = 235  ! Mean convective precipitation rate               kg m-2 s-1
          case ( 'MSR'     , 'msr'      ); pid = 031; tabid = 235  ! Mean snowfall rate                               kg m-2 s-1
          case ( 'MSSHF'   , 'msshf'    ); pid = 033; tabid = 235  ! Mean surface sensible heat flux                  W m-2     
          case ( 'MSLHF'   , 'mslhf'    ); pid = 034; tabid = 235  ! Mean surface latent heat flux                    W m-2     
          case ( 'MSDWSWRF', 'msdwswrf' ); pid = 035; tabid = 235  ! Mean surface downward short-wave radiation flux  W m-2     
          case ( 'MSDWLWRF', 'msdwlwrf' ); pid = 036; tabid = 235  ! Mean surface downward long-wave radiation flux   W m-2     
          case ( 'MSNSWRF' , 'msnswrf'  ); pid = 037; tabid = 235  ! Mean surface net short-wave radiation flux       W m-2     
          case ( 'MSNLWRF' , 'msnlwrf'  ); pid = 038; tabid = 235  ! Mean surface net long-wave radiation flux        W m-2     
          case ( 'METSS'   , 'metss'    ); pid = 041; tabid = 235  ! Mean eastward turbulent surface stress           N m-2     
          case ( 'MNTSS'   , 'mntss'    ); pid = 042; tabid = 235  ! Mean northward turbulent surface stress          N m-2     
#else
          case ( 'LSP' , 'lsp'  ); pid = 142
          case ( 'CP'  , 'cp'   ); pid = 143
          case ( 'SF'  , 'sf'   ); pid = 144
          case ( 'SSHF', 'sshf' ); pid = 146
          case ( 'SLHF', 'slhf' ); pid = 147  ! surface latent heat flux  (W m**-2 s)
          case ( 'SSRD', 'ssrd' ); pid = 169  ! surface solar radiation downwards
          case ( 'STRD', 'strd' ); pid = 175  ! surface thermal radiation downwards
          case ( 'SSR' , 'ssr'  ); pid = 176  ! surface solar radiation
          case ( 'STR' , 'str'  ); pid = 177  ! surface thermal radiation
          case ( 'EWSS', 'ewss' ); pid = 180
          case ( 'NSSS', 'nsss' ); pid = 181
#endif

          case ( 'LNSP', 'lnsp' ); pid = 152
          case ( 'D'   , 'd'    ); pid = 155
          case ( 'GH'  , 'gh'   ); pid = 156    ! geopotential height

          case ( 'BLH' , 'blh'  ); pid = 159    ! boundary layer height

          case ( 'U10M', 'u10m' ); pid = 165
          case ( 'V10M', 'v10m' ); pid = 166
          case ( 'T2M' , 't2m'  ); pid = 167
          case ( 'D2M' , 'd2m'  ); pid = 168

          case ( 'LSM' , 'lsm'  ); pid = 172   ! land/sea mask

#ifdef with_ec_aver
          case ( 'z0m' , 'SR', 'sr'       ); pid = 244  ! Forecast Surface Roughness (m)
          case ( 'AL'  , 'al', 'albedo'   ); pid = 243  ! Forecst Albedo (0-1)
#else
          case ( 'z0m' , 'SR', 'sr'       ); pid = 173  ! Surface Roughness (m)
          case ( 'AL'  , 'al', 'albedo'   ); pid = 174  ! Albedo   (0-1)
#endif


          case ( 'LSRH', 'lsrh' ); pid = 234  ! Log. Surf.Roughn. length for Heat

          case ( 'ustar'          ); pid = 250
          case ( 'Raero'          ); pid = 251

          case ( 'CLWC' , 'clwc'  ); pid = 246  ! cloud liquid water content
          case ( 'CIWC' , 'ciwc'  ); pid = 247  ! cloud ice water content
          case ( 'CC'   , 'cc'    ); pid = 248  ! cloud cover

          case ( 'SRC'  , 'src'   ); pid = 198  ! skin reservoir content
          case ( 'SKT'  , 'skt'   ); pid = 235  ! skin temperature

          case default
            write (gol,'("unknown key `",a,"`")') trim(key); call goErr
            write (gol,'("  table : ",a)') trim(table); call goErr
            TRACEBACK; status=1; return
        end select

      ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      ! TM codes
      ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      case ( 'tm' )
      
        select case ( key )

          case ( 'PV'           ); pid =  60   ! potential vorticity (K m2/kg/s)

          case ( 'K'            ); pid = 109   ! diffusion (m2/s)

          case ( 'u'            ); pid = 131   ! u wind
          case ( 'v'            ); pid = 132   ! v wind

          case ( 'ps'           ); pid = 160   ! average surface pressure
          case ( 'pu'           ); pid = 158   ! u flux
          case ( 'pv'           ); pid = 159   ! v flux
          case ( 'pw'           ); pid = 157   ! w flux

          case ( 'Z'            ); pid = 129   ! geopotential, orography at surface

          case ( 'T'            ); pid = 130   ! temperature

          case ( 'Q'            ); pid = 133   ! specific humidity

          case ( 'GH'           ); pid = 156    ! geopotential height

          case ( 'eu'           ); pid = 161    ! entrainment updraft
          case ( 'du'           ); pid = 162    ! detrainment updraft
          case ( 'ed'           ); pid = 164    ! entrainment downdraft
          case ( 'dd'           ); pid = 165    ! detrainment downdraft

          case ( 'dk'           ); pid = 163    ! vertical diffusion coef.

          case ( 'clbas'        ); pid = 190    ! cloud base
          case ( 'cltop'        ); pid = 191    ! cloud top
          case ( 'cllfs'        ); pid = 192

          case ( 'Kz'           ); pid = 163

          case ( 'pblh'         ); pid = 159
          case ( 'pblh?'        ); pid = 203

          case ( 'lsp'          ); pid = 142 
          case ( 'cp'           ); pid = 143 
          case ( 'sf'           ); pid = 144 
          case ( 'sshf'         ); pid = 146 
          case ( 'slhf'         ); pid = 147  ! surface latent heat flux  (W m**-2 s)

          case ( 'slw'          ); pid = 140
          case ( 'sd'           ); pid = 141
          case ( 'T2M', 'T2m', 't2m' ); pid = 167
          case ( 'D2M', 'D2m', 'd2m' ); pid = 168
          case ( 'z0m', 'SR'    ); pid = 173
          case ( 'al'           ); pid = 174  ! Albedo    (0-1) 

          case ( 'ewss'         ); pid = 180                                             
          case ( 'nsss'         ); pid = 181                                             

          case ( 'ustar'        ); pid = 250                                             
          case ( 'Raero'        ); pid = 251                                             

          case ( 'CLWC', 'clwc' ); pid = 246  ! cloud liquid water content
          case ( 'CIWC', 'ciwc' ); pid = 247  ! cloud ice water content
          case ( 'CC'  , 'cc'   ); pid = 248  ! cloud cover
          case ( 'CCO' , 'cco'  ); pid = 249  ! overhead cloud cover
          case ( 'CCU' , 'ccu'  ); pid = 250  ! underfeet cloud cover

          case ( 'ssr'          ); pid = 176  ! surface solar radiation
          case ( 'src'          ); pid = 198  ! skin reservoir content

          case default
            write (gol,'("unknown key `",a,"`")') trim(key); call goErr
            write (gol,'("  table : ",a)') trim(table); call goErr
            TRACEBACK; status=1; return
        end select

      case default
        write (gol,'("unknown table `",a,"`")') trim(table); call goErr
        TRACEBACK; status=1; return
    end select
    
    ! ok
    status = 0

  end subroutine GetPid

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


  subroutine GetPidName( table, pid, name, status  )
  
    use GO, only : gol, goErr
  
    ! --- in/out ------------------------------
    
    character(len=*), intent(in)        ::  table
    integer, intent(in)                 ::  pid
    character(len=*), intent(out)       ::  name
    integer, intent(out)                ::  status
    
    ! --- const --------------------------------------
    
    character(len=*), parameter  ::  rname = mname//'/GetPidName'
    
    ! --- begin -------------------------------
    
    select case ( table )
    
      ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      ! ECMWF codes
      ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      case ( 'ec' )
      
        select case ( pid )
          case ( 109 )  ;  name = 'K   '     ! diffusion (m2/s); experimental
          case ( 129 )  ;  name = 'Z   '
          case ( 130 )  ;  name = 'T   '
          case ( 131 )  ;  name = 'U   '
          case ( 132 )  ;  name = 'V   '
          case ( 133 )  ;  name = 'Q   '
          case ( 134 )  ;  name = 'SP  '
          case ( 135 )  ;  name = 'W   '
          case ( 138 )  ;  name = 'VO  '
          case ( 141 )  ;  name = 'SD  '
          case ( 142 )  ;  name = 'LSP '
          case ( 143 )  ;  name = 'CP  '
          case ( 144 )  ;  name = 'SF  '
          case ( 146 )  ;  name = 'SSHF'
          case ( 147 )  ;  name = 'SLHF'
          case ( 152 )  ;  name = 'LNSP'
          case ( 155 )  ;  name = 'D   '
          case ( 156 )  ;  name = 'GH  '
          case ( 159 )  ;  name = 'BLH '
          case ( 165 )  ;  name = 'U10M'
          case ( 166 )  ;  name = 'V10M'
          case ( 167 )  ;  name = 'T2M '
          case ( 168 )  ;  name = 'D2M '
          case ( 172 )  ;  name = 'LSM '
          case ( 173 )  ;  name = 'SR  '
          case ( 174 )  ;  name = 'AL  '
          case ( 176 )  ;  name = 'SSR '
          case ( 180 )  ;  name = 'EWSS'
          case ( 181 )  ;  name = 'NSSS'
          case ( 198 )  ;  name = 'SRC '
          case ( 234 )  ;  name = 'LSRH'
          case ( 246 )  ;  name = 'CLWC'
          case ( 247 )  ;  name = 'CIWC'
          case ( 248 )  ;  name = 'CC  '
          case default
            write (name,'("p",i3.3)') pid
        end select
    

      ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      ! TM codes
      ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      case ( 'tm' )
      
        select case ( pid )
          case ( 104 )  ;  name = 'MU  '     !    updraught mass flux         kg m-2
          case ( 105 )  ;  name = 'MD  '     !  downdraught mass flux         kg m-2
          case ( 106 )  ;  name = 'DU  '     !    updraught detrainment rate  s m-1 
          case ( 107 )  ;  name = 'DD  '     !  downdraught detrainment rate  s m-1 
          case ( 109 )  ;  name = 'K   '     ! diffusion (m2/s); experimental
          case ( 129 )  ;  name = 'Z   '
          case ( 130 )  ;  name = 'T   '
          case ( 131 )  ;  name = 'U   '
          case ( 132 )  ;  name = 'V   '
          case ( 133 )  ;  name = 'Q   '
          case ( 134 )  ;  name = 'SP  '
          case ( 135 )  ;  name = 'W   '
          case ( 138 )  ;  name = 'VO  '
          case ( 141 )  ;  name = 'SD  '
          case ( 142 )  ;  name = 'LSP '
          case ( 143 )  ;  name = 'CP  '
          case ( 144 )  ;  name = 'SF  '
          case ( 146 )  ;  name = 'SSHF'
          case ( 147 )  ;  name = 'SLHF'
          case ( 152 )  ;  name = 'LNSP'
          case ( 155 )  ;  name = 'D   '
          case ( 156 )  ;  name = 'zg  '      ! ECMWF : GH
          case ( 157 )  ;  name = 'pw  '
          case ( 158 )  ;  name = 'pu  '
          case ( 159 )  ;  name = 'pv  '
          case ( 160 )  ;  name = 'sp  '
          case ( 161 )  ;  name = 'eu  '
          case ( 162 )  ;  name = 'du  '
          case ( 163 )  ;  name = 'dk  '
          case ( 164 )  ;  name = 'ed  '
          case ( 165 )  ;  name = 'dd  '
          case ( 167 )  ;  name = 'T2M '
          case ( 168 )  ;  name = 'D2M '
          case ( 172 )  ;  name = 'LSM '
          case ( 173 )  ;  name = 'SR  '
          case ( 174 )  ;  name = 'AL  '
          case ( 176 )  ;  name = 'SSR '
          case ( 180 )  ;  name = 'EWSS'
          case ( 181 )  ;  name = 'NSSS'
          case ( 190 )  ;  name = 'clb '
          case ( 191 )  ;  name = 'clt '
          case ( 192 )  ;  name = 'clfs'
          case ( 198 )  ;  name = 'SRC '
          case ( 203 )  ;  name = 'blh '     ! ECMWF's BLH has code 159, but this is pv in TM ...
          case ( 234 )  ;  name = 'LSRH'
          case ( 246 )  ;  name = 'CLWC'
          case ( 247 )  ;  name = 'CIWC'
          case ( 248 )  ;  name = 'CC  '
          case ( 249 )  ;  name = 'cco '
          case ( 250 )  ;  name = 'ccu '
          case default
            write (name,'("p",i3.3)') pid
        end select
    
      case default
        write (gol,'("unknown table `",a,"`")') trim(table); call goErr
        TRACEBACK; status=1; return
    end select

    ! ok
    status = 0
    
  end subroutine GetPidName
  

end module grib_table