phys/module_checkerror.F

   1 !Modified to use wrf error routines by Eric Kemp, 2 Aug 2011
   2 !SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU
   3 !SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU
   4
   5  module module_checkerror
   6  implicit none
   7
   8 !--------------------------------------------------------------------------------------------------
   9 !              = Goddard Satellite Data Simulator Unit =
  10 !
  11 ! NASA GSFC makes no representations about the suitability of software for any purpose.
  12 ! It is provided as is without express or implied warranty. Neither NASA GSFC (the US
  13 ! government) nor Principal Developers (their organizations) shall be liable for any
  14 ! damages suffered by the user of this software. In addition, please do not distribute
  15 ! the software to third party.
  16 !
  17 ! Comments:
  18 !  This routine checks the presence of anomalous physical value.
  19 !
  20 ! 1. How to use
  21 !
  22 ! You can call subroutine checkerror like this.
  23 !
  24 !                 !    input               input         input     input   input      input/output
  25 ! call checkerror( "subroutine name', 'parameter name', i_index, j_index, k_index, float_array(i,k,j) )
  26 !
  27 ! a) 'subroutine_name' must be the subroutine name that call check_error.
  28 !
  29 !
  30 ! b) 'parameter name' can be must be following characters:
  31 !
  32 !   'temperature_K'       This is temperature in Kelvin.
  33 !   'temperature_degC'    This is temperature in degree Celcius.
  34 !   'pressure_Pa'         This is pressure in Pascal.
  35 !   'radiationflux_W/m2'  This is radiation flux in Watts per square meter.
  36 !   'condensate_g/m3'     This is cloud rain condensates in gram per cubic meter.
  37 !   'condensate_kg/kg'    This is cloud rain condensate in mixing ratio.
  38 !   'aerosol_g/m3'        This is aerosol in gram per cubic meter.
  39 !   'aerosol_ug/kg'       This is aerosol in mixing ratio.
  40 !   'albedo'              This is surface albedo.
  41 !   'emissivity'          This is surface emissivity
  42 !
  43 ! c) float_array can be either single or double precision. But it must be zero dimension for interface.
  44 !
  45 !
  46 ! History:
  47 ! 02/2010  Toshi Matsui@NASA GSFC ; Initial
  48 !
  49 !----------------------------------------------------------------------------------------------
  50
  51 !
  52 ! Encapsulation control
  53 !
  54  private             ! All parameters and subourtines are non accessible.
  55  public  checkerror  ! Only this function is accesible.
  56
  57 ! ################################################################################
  58 ! ############################    Module Interface     ###########################
  59 ! ################################################################################
  60
  61   interface checkerror
  62     module procedure checkerror_single
  63     module procedure checkerror_double
  64 !    module procedure checkerror_integer
  65   end interface
  66
  67  contains
  68
  69 !SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU
  70 !SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU
  71
  72  subroutine checkerror_single(subroutine_name, param_id,i,k,j,input_real)
  73 #ifndef NO_IEEE_MODULE
  74  use, intrinsic :: ieee_arithmetic
  75 #endif
  76  implicit none
  77  character*(*),intent(in) :: subroutine_name
  78  character*(*),intent(in) :: param_id
  79  integer,intent(in) :: i,k,j  ! array index
  80  real(4),intent(in) :: input_real
  81
  82  character(len=132) :: string
  83
  84  select case(trim(param_id))
  85  case('temperature_K')
  86
  87   if(input_real < 0. .or. input_real > 1000. ) then
  88 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
  89 !               ' out of range at grid(i,k,j) =',i,k,j
  90 !       stop 'Terminate run.'
  91        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
  92                ' out of range at grid(i,k,j) =',i,k,j
  93        call wrf_message(string)
  94        call wrf_error_fatal('Terminate run.')
  95   endif
  96
  97  case('temperature_degC')
  98
  99   if(input_real < -274. .or. input_real > 1000. ) then
 100 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 101 !               ' out of range at grid(i,k,j) =',i,k,j
 102 !       stop 'Terminate run.'
 103        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 104                ' out of range at grid(i,k,j) =',i,k,j
 105        call wrf_message(string)
 106        call wrf_error_fatal('Terminate run.')
 107   endif
 108
 109  case('pressure_Pa')
 110
 111   if(input_real < 0. .or. input_real > 200000. ) then
 112 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 113 !               ' out of range at grid(i,k,j) =',i,k,j
 114 !       stop 'Terminate run.'
 115        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 116                ' out of range at grid(i,k,j) =',i,k,j
 117        call wrf_message(string)
 118        call wrf_error_fatal('Terminate run.')
 119   endif
 120
 121  case('radiationflux_W/m2')
 122
 123   if(input_real < -10000. .or. input_real > 10000. ) then
 124 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 125 !               ' out of range at grid(i,k,j) =',i,k,j
 126 !       stop 'Terminate run.'
 127        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 128                ' out of range at grid(i,k,j) =',i,k,j
 129        call wrf_message(string)
 130        call wrf_error_fatal('Terminate run.')
 131   endif
 132
 133  case('condensate_g/m3')
 134
 135   if(input_real < 0. .or. input_real > 10000. ) then
 136 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 137 !               ' out of range at grid(i,k,j) =',i,k,j
 138 !       stop 'Terminate run.'
 139        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 140                ' out of range at grid(i,k,j) =',i,k,j
 141        call wrf_message(string)
 142        call wrf_error_fatal('Terminate run.')
 143   endif
 144
 145  case('condensate_kg/kg')
 146
 147   if(input_real < 0. .or. input_real > 10000. ) then
 148 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 149 !               ' out of range at grid(i,k,j) =',i,k,j
 150 !       stop 'Terminate run.'
 151        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 152                ' out of range at grid(i,k,j) =',i,k,j
 153        call wrf_message(string)
 154        call wrf_error_fatal('Terminate run.')
 155   endif
 156
 157  case('aerosol_g/m3')
 158
 159   if(input_real < 0. .or. input_real > 1000. ) then
 160 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 161 !               ' out of range at grid(i,k,j) =',i,k,j
 162 !       stop 'Terminate run.'
 163        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 164                ' out of range at grid(i,k,j) =',i,k,j
 165        call wrf_message(string)
 166        call wrf_error_fatal('Terminate run.')
 167   endif
 168
 169  case('aerosol_ug/kg')
 170
 171   if(input_real < 0. .or. input_real > 1000. ) then
 172 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 173 !               ' out of range at grid(i,k,j) =',i,k,j
 174 !       stop 'Terminate run.'
 175        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 176                ' out of range at grid(i,k,j) =',i,k,j
 177        call wrf_message(string)
 178        call wrf_error_fatal('Terminate run.')
 179   endif
 180
 181  case('albedo')
 182
 183   if(input_real < 0. .or. input_real > 1. ) then
 184 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 185 !               ' out of range at grid(i,k,j) =',i,k,j
 186 !       stop 'Terminate run.'
 187        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 188                ' out of range at grid(i,k,j) =',i,k,j
 189        call wrf_message(string)
 190        call wrf_error_fatal('Terminate run.')
 191   endif
 192
 193  case('emissivity')
 194
 195   if(input_real < 0. .or. input_real > 1. ) then
 196 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 197 !               ' out of range at grid(i,k,j) =',i,k,j
 198 !       stop 'Terminate run.'
 199        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 200                ' out of range at grid(i,k,j) =',i,k,j
 201        call wrf_message(string)
 202        call wrf_error_fatal('Terminate run.')
 203   endif
 204
 205
 206  case default
 207 !      print*,'MSG checkeror_float: There is no such param_id',trim(param_id)
 208 !      stop
 209       write(string,*) 'MSG checkerror_float: There is no such param_id',trim(param_id)
 210       call wrf_message(string)
 211       call wrf_error_fatal('Terminate run.')
 212  end select
 213
 214 ! EMK...Check for infinity and NaNs
 215  if (abs(input_real) >= huge(input_real)) then
 216     write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 217                ' Infinity at grid(i,k,j) =',i,k,j
 218     call wrf_message(string)
 219     call wrf_error_fatal('Terminate run.')
 220  end if
 221
 222 #ifndef NO_IEEE_MODULE
 223  if (ieee_is_nan(input_real)) then
 224     write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 225                ' NaN at grid(i,k,j) =',i,k,j
 226     call wrf_message(string)
 227     call wrf_error_fatal('Terminate run.')
 228  end if
 229 #endif
 230
 231  end subroutine checkerror_single
 232
 233 !SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU
 234 !SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU
 235
 236  subroutine checkerror_double(subroutine_name, param_id,i,k,j,input_real)
 237 #ifndef NO_IEEE_MODULE
 238  use, intrinsic :: ieee_arithmetic
 239 #endif
 240  implicit none
 241  character*(*),intent(in) :: subroutine_name
 242  character*(*),intent(in) :: param_id
 243  integer,intent(in) :: i,k,j  ! array index
 244  real(8),intent(in) :: input_real
 245
 246  character(len=132) :: string
 247
 248  select case(trim(param_id))
 249  case('temperature_K')
 250
 251   if(input_real < 0. .or. input_real > 1000. ) then
 252 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 253 !               ' out of range at grid(i,k,j) =',i,k,j
 254 !       stop 'Terminate run.'
 255        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 256                ' out of range at grid(i,k,j) =',i,k,j
 257        call wrf_message(string)
 258        call wrf_error_fatal('Terminate run.')
 259   endif
 260
 261  case('temperature_degC')
 262
 263   if(input_real < -274. .or. input_real > 1000. ) then
 264 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 265 !               ' out of range at grid(i,k,j) =',i,k,j
 266 !       stop 'Terminate run.'
 267        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 268                ' out of range at grid(i,k,j) =',i,k,j
 269        call wrf_message(string)
 270        call wrf_error_fatal('Terminate run.')
 271   endif
 272
 273  case('pressure_Pa')
 274
 275   if(input_real < 0. .or. input_real > 200000. ) then
 276 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 277 !               ' out of range at grid(i,k,j) =',i,k,j
 278 !       stop 'Terminate run.'
 279        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 280                ' out of range at grid(i,k,j) =',i,k,j
 281        call wrf_message(string)
 282        call wrf_error_fatal('Terminate run.')
 283   endif
 284
 285  case('radiationflux_W/m2')
 286
 287   if(input_real < -10000. .or. input_real > 10000. ) then
 288 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 289 !               ' out of range at grid(i,k,j) =',i,k,j
 290 !       stop 'Terminate run.'
 291        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 292                ' out of range at grid(i,k,j) =',i,k,j
 293        call wrf_message(string)
 294        call wrf_error_fatal('Terminate run.')
 295
 296   endif
 297
 298  case('condensate_g/m3')
 299
 300   if(input_real < 0. .or. input_real > 10000. ) then
 301 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 302 !               ' out of range at grid(i,k,j) =',i,k,j
 303 !       stop 'Terminate run.'
 304        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 305                ' out of range at grid(i,k,j) =',i,k,j
 306        call wrf_message(string)
 307        call wrf_error_fatal('Terminate run.')
 308   endif
 309
 310  case('condensate_kg/kg')
 311
 312   if(input_real < 0. .or. input_real > 10000. ) then
 313 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 314 !               ' out of range at grid(i,k,j) =',i,k,j
 315 !       stop 'Terminate run.'
 316        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 317                ' out of range at grid(i,k,j) =',i,k,j
 318        call wrf_message(string)
 319        call wrf_error_fatal('Terminate run.')
 320   endif
 321
 322  case('aerosol_g/m3')
 323
 324   if(input_real < 0. .or. input_real > 1000. ) then
 325 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 326 !               ' out of range at grid(i,k,j) =',i,k,j
 327 !       stop 'Terminate run.'
 328        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 329                ' out of range at grid(i,k,j) =',i,k,j
 330        call wrf_message(string)
 331        call wrf_error_fatal('Terminate run.')
 332   endif
 333
 334  case('aerosol_ug/kg')
 335
 336   if(input_real < 0. .or. input_real > 1000. ) then
 337 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 338 !               ' out of range at grid(i,k,j) =',i,k,j
 339 !       stop 'Terminate run.'
 340        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 341                ' out of range at grid(i,k,j) =',i,k,j
 342        call wrf_message(string)
 343        call wrf_error_fatal('Terminate run.')
 344   endif
 345
 346  case('albedo')
 347
 348   if(input_real < 0. .or. input_real > 1. ) then
 349 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 350 !               ' out of range at grid(i,k,j) =',i,k,j
 351 !       stop 'Terminate run.'
 352        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 353                ' out of range at grid(i,k,j) =',i,k,j
 354        call wrf_message(string)
 355        call wrf_error_fatal('Terminate run.')
 356   endif
 357
 358  case('emissivity')
 359
 360   if(input_real < 0. .or. input_real > 1. ) then
 361 !       print*, 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 362 !               ' out of range at grid(i,k,j) =',i,k,j
 363 !       stop 'Terminate run.'
 364        write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 365                ' out of range at grid(i,k,j) =',i,k,j
 366        call wrf_message(string)
 367        call wrf_error_fatal('Terminate run.')
 368   endif
 369
 370  case default
 371 !      print*,'MSG checkerror_double: There is no such param_id',trim(param_id)
 372 !      stop
 373       write(string,*) 'MSG checkerror_double: There is no such param_id',trim(param_id)
 374       call wrf_message(string)
 375        call wrf_error_fatal('Terminate run.')
 376  end select
 377
 378 ! EMK...Check for infinity and NaNs
 379  if (abs(input_real) >= huge(input_real)) then
 380     write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 381                ' Infinity at grid(i,k,j) =',i,k,j
 382     call wrf_message(string)
 383     call wrf_error_fatal('Terminate run.')
 384  end if
 385
 386 #ifndef NO_IEEE_MODULE
 387  if (ieee_is_nan(input_real)) then
 388     write(string,*) 'MSG '//trim(subroutine_name)//': '//trim(param_id)//' =',input_real,&
 389                ' NaN at grid(i,k,j) =',i,k,j
 390     call wrf_message(string)
 391     call wrf_error_fatal('Terminate run.')
 392  end if
 393 #endif
 394
 395  end subroutine checkerror_double
 396
 397 !SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU
 398 !SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU
 399
 400  end module module_checkerror
 401
 402 !SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU
 403 !SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU SDSU