!### 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