dyn_em/module_initialize_real.F

   1 !REAL:MODEL_LAYER:INITIALIZATION
   2
   3 #ifndef VERT_UNIT
   4 !  This MODULE holds the routines which are used to perform various initializations
   5 !  for the individual domains, specifically for the Eulerian, mass-based coordinate.
   6
   7 !-----------------------------------------------------------------------
   8
   9 MODULE module_initialize_real
  10
  11    USE module_bc
  12    USE module_configure
  13    USE module_domain
  14    USE module_io_domain
  15    USE module_model_constants
  16    USE module_state_description
  17    USE module_timing
  18    USE module_soil_pre
  19    USE module_date_time
  20    USE module_llxy
  21    USE module_polarfft
  22 #ifdef DM_PARALLEL
  23    USE module_dm
  24    USE module_comm_dm, ONLY : &
  25                            HALO_EM_INIT_1_sub   &
  26                           ,HALO_EM_INIT_2_sub   &
  27                           ,HALO_EM_INIT_3_sub   &
  28                           ,HALO_EM_INIT_4_sub   &
  29                           ,HALO_EM_INIT_5_sub   &
  30                           ,HALO_EM_INIT_6_sub   &
  31                           ,HALO_EM_VINTERP_UV_1_sub
  32 #endif
  33
  34    REAL , SAVE :: p_top_save
  35    INTEGER :: internal_time_loop
  36
  37 CONTAINS
  38
  39 !-------------------------------------------------------------------
  40
  41    SUBROUTINE init_domain ( grid )
  42
  43       IMPLICIT NONE
  44
  45       !  Input space and data.  No gridded meteorological data has been stored, though.
  46
  47 !     TYPE (domain), POINTER :: grid
  48       TYPE (domain)          :: grid
  49
  50       !  Local data.
  51
  52       INTEGER :: idum1, idum2
  53
  54       CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
  55
  56         CALL init_domain_rk( grid &
  57 !
  58 #include "actual_new_args.inc"
  59 !
  60       )
  61    END SUBROUTINE init_domain
  62
  63 !-------------------------------------------------------------------
  64
  65    SUBROUTINE init_domain_rk ( grid &
  66 !
  67 #include "dummy_new_args.inc"
  68 !
  69    )
  70
  71       USE module_optional_input
  72       USE module_radiation_driver, ONLY: cal_cldfra3
  73       USE module_dm, ONLY : wrf_dm_max_real
  74       use module_madwrf, only : Init_madwrf_clouds, Init_madwrf_tracers
  75
  76       IMPLICIT NONE
  77
  78       !  Input space and data.  No gridded meteorological data has been stored, though.
  79
  80 !     TYPE (domain), POINTER :: grid
  81       TYPE (domain)          :: grid
  82
  83 #include "dummy_new_decl.inc"
  84
  85       TYPE (grid_config_rec_type)              :: config_flags
  86
  87       !  Local domain indices and counters.
  88
  89       INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
  90       INTEGER :: loop , num_seaice_changes
  91
  92       INTEGER :: ids, ide, jds, jde, kds, kde, &
  93                  ims, ime, jms, jme, kms, kme, &
  94                  its, ite, jts, jte, kts, kte, &
  95                  ips, ipe, jps, jpe, kps, kpe, &
  96                  i, j, k, kk
  97
  98       INTEGER :: imsx, imex, jmsx, jmex, kmsx, kmex,    &
  99                  ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
 100                  imsy, imey, jmsy, jmey, kmsy, kmey,    &
 101                  ipsy, ipey, jpsy, jpey, kpsy, kpey
 102
 103       INTEGER :: ns
 104
 105       !  Local data
 106
 107       INTEGER :: error
 108       INTEGER :: im, num_3d_m, num_3d_s
 109       REAL    :: B1, B2, B3, B4, B5
 110       REAL    :: p_surf, p_level
 111       REAL    :: cof1, cof2
 112       REAL    :: qvf , qvf1 , qvf2 , qtot, pd_surf
 113       REAL    :: p00 , t00 , a , tiso, p_strat, a_strat
 114       REAL    :: hold_znw , ptemp
 115       REAL    :: vap_pres_mb , sat_vap_pres_mb
 116       LOGICAL :: were_bad
 117
 118       LOGICAL :: stretch_grid, dry_sounding, debug
 119       INTEGER :: IICOUNT, icount
 120
 121       REAL :: p_top_requested , temp
 122       INTEGER :: num_metgrid_levels
 123       INTEGER, PARAMETER :: num_wif_levels_default = 30
 124       INTEGER :: aer_init_opt
 125       REAL , DIMENSION(max_eta) :: eta_levels
 126
 127       INTEGER :: auto_levels_opt
 128       REAL :: max_dz, dzbot, dzstretch_s, dzstretch_u, z1
 129
 130       INTEGER:: i_end, j_end
 131       REAL, ALLOCATABLE, DIMENSION(:):: temp_P, temp_T, temp_R, temp_Dz
 132       REAL, ALLOCATABLE, DIMENSION(:):: temp_Qv, temp_Qc, temp_Qi, temp_Qs
 133       REAL, ALLOCATABLE, DIMENSION(:):: temp_CF, temp_Nc, temp_Ni
 134       REAL:: max_relh, temp_xland, gridkm
 135       LOGICAL :: debug_flag = .FALSE.
 136
 137       REAL :: dclat
 138
 139 !      INTEGER , PARAMETER :: nl_max = 1000
 140 !      REAL , DIMENSION(nl_max) :: grid%dn
 141
 142 integer::oops1,oops2
 143
 144       REAL    :: zap_close_levels
 145       INTEGER :: force_sfc_in_vinterp
 146       INTEGER :: interp_type , lagrange_order , extrap_type , t_extrap_type
 147       INTEGER :: linear_interp
 148       LOGICAL :: lowest_lev_from_sfc , use_levels_below_ground , use_surface
 149       LOGICAL :: we_have_tavgsfc , we_have_tsk
 150
 151       INTEGER :: lev500 , loop_count
 152       REAL    :: zl , zu , pl , pu , z500 , dz500 , tvsfc , dpmu
 153       REAL    :: pfu, pfd, phm
 154
 155       LOGICAL , PARAMETER :: want_full_levels = .TRUE.
 156       LOGICAL , PARAMETER :: want_half_levels = .FALSE.
 157
 158       CHARACTER (LEN=256) :: a_message, mminlu
 159       REAL :: max_mf
 160
 161       !  Excluded middle.
 162
 163       LOGICAL :: any_valid_points
 164       INTEGER :: i_valid , j_valid
 165
 166       !  Vert interpolation in WRF
 167
 168       INTEGER :: k_max_p , k_min_p
 169
 170 !-- Carsel and Parrish [1988]
 171         REAL , DIMENSION(100) :: lqmi
 172
 173       REAL , DIMENSION(100) :: thickness , levels
 174       REAL :: t_start , t_end
 175       REAL , ALLOCATABLE , DIMENSION(:,:) :: clat_glob
 176
 177       ! added for multiple specified sets of eta_levels with vertical grid nesting
 178       INTEGER :: ks, ke, id
 179       LOGICAL :: vnest !T if using vertical nesting with vet_refine_method=2, otherwise F
 180
 181       INTEGER :: j_save
 182       INTEGER :: change_soil, change_soilw, iforce
 183
 184       REAL:: temp_rho
 185
 186       LOGICAL :: wif_upside_down = .FALSE.
 187
 188       !  Test on consistency between namelist settings and the available data from geogrid.
 189
 190       INTEGER :: geogrid_flag_error
 191
 192       !  Vertical pressure checks
 193
 194       REAL :: press_above, press_below
 195
 196       !  Dimension information stored in grid data structure.
 197
 198       CALL cpu_time(t_start)
 199       CALL get_ijk_from_grid (  grid ,                   &
 200                                 ids, ide, jds, jde, kds, kde,    &
 201                                 ims, ime, jms, jme, kms, kme,    &
 202                                 ips, ipe, jps, jpe, kps, kpe,    &
 203                                 imsx, imex, jmsx, jmex, kmsx, kmex,    &
 204                                 ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
 205                                 imsy, imey, jmsy, jmey, kmsy, kmey,    &
 206                                 ipsy, ipey, jpsy, jpey, kpsy, kpey )
 207       its = ips ; ite = ipe ; jts = jps ; jte = jpe ; kts = kps ; kte = kpe
 208
 209       CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
 210
 211       !  Check flags from geogrid and the various model settings for any inconsistency.
 212       !  The optional data from geogrid mostly started with the v4.0 release. Older
 213       !  WPS data could have the required fields. Assume users know what they are
 214       !  doing when they bring old data into the newer real program ...
 215
 216       IF ( grid%v4_metgrid ) THEN
 217
 218          geogrid_flag_error = 0
 219
 220          IF ( ( config_flags%topo_wind          .EQ. 1          ) .AND. ( flag_var_sso    .EQ. 0 ) ) THEN
 221             CALL wrf_message ( '----- ERROR: topo_wind          = 1 AND flag_var_sso    = 0 ' )
 222             geogrid_flag_error = geogrid_flag_error + 1
 223          END IF
 224
 225          IF ( ( config_flags%sf_lake_physics    .EQ. 1           ) .AND. ( flag_lake_depth .EQ. 0 ) ) THEN
 226             CALL wrf_message ( '----- ERROR: sf_lake_physics    = 1 AND flag_lake_depth = 0 ' )
 227             geogrid_flag_error = geogrid_flag_error + 1
 228          END IF
 229
 230          IF ( ( config_flags%sf_surface_physics .EQ. pxlsmscheme  ) .AND. ( flag_imperv    .EQ. 0 ) ) THEN
 231             CALL wrf_message ( '----- ERROR: sf_surface_physics = 7 AND flag_imperv     = 0 ' )
 232             geogrid_flag_error = geogrid_flag_error + 1
 233          END IF
 234
 235          IF ( ( config_flags%sf_surface_physics .EQ. pxlsmscheme  ) .AND. ( flag_canfra    .EQ. 0 ) ) THEN
 236             CALL wrf_message ( '----- ERROR: sf_surface_physics = 7 AND flag_canfra     = 0 ' )
 237             geogrid_flag_error = geogrid_flag_error + 1
 238          END IF
 239
 240          IF ( ( config_flags%mp_physics         .EQ. thompsonaero ) .AND. &
 241               ( config_flags%dust_emis          .EQ. 1            ) .AND. ( flag_erod      .EQ. 0 ) ) THEN
 242             CALL wrf_message ( '----- ERROR: mp=28 AND dust_emis= 1 AND flag_erod       = 0 ' )
 243             geogrid_flag_error = geogrid_flag_error + 1
 244          END IF
 245
 246          IF ( ( config_flags%mp_physics         .EQ. thompsonaero ) .AND. &
 247               ( config_flags%dust_emis          .EQ. 1            ) .AND. ( flag_clayfrac  .EQ. 0 ) ) THEN
 248             CALL wrf_message ( '----- ERROR: mp=28 AND dust_emis= 1 AND flag_clayfrac   = 0 ' )
 249             geogrid_flag_error = geogrid_flag_error + 1
 250          END IF
 251
 252          IF ( ( config_flags%mp_physics         .EQ. thompsonaero ) .AND. &
 253               ( config_flags%dust_emis          .EQ. 1            ) .AND. ( flag_sandfrac  .EQ. 0 ) ) THEN
 254             CALL wrf_message ( '----- ERROR: mp=28 AND dust_emis= 1 AND flag_sandfrac   = 0 ' )
 255             geogrid_flag_error = geogrid_flag_error + 1
 256          END IF
 257
 258          IF ( geogrid_flag_error .GT. 0 ) THEN
 259             CALL wrf_error_fatal ('Either modify the namelist settings, or rebuild the geogrid/metgrid data' )
 260          END IF
 261
 262          !  Geogrid flags that are not yet used: FLAG_FRC_URB2D FLAG_LAI12M FLAG_URB_PARAM
 263
 264       END IF
 265
 266       !  Would the user prefer to forego the use of the level of max winds, or the
 267       !  tropopause level data?  This is an option the user may select.  While the
 268       !  additional data is able to provide good information (such as a better
 269       !  resolution of the jet, a better kink for the tropopause), there are
 270       !  horizontal gradients that are introduced.  Near a boundary, these gradients
 271       !  would be permanent (due to their inclusion in the LBC file).  To turn "off"
 272       !  the use of the max wind/trop data, set the flags for those levels to zero.
 273
 274       flag_pmaxw   = 0
 275       flag_pmaxwnn = 0
 276       flag_ptrop   = 0
 277       flag_ptropnn = 0
 278       IF ( ( config_flags%use_maxw_level .EQ. 0 ) .AND. &
 279            ( ( flag_tmaxw .EQ. 1 ) .OR. ( flag_umaxw .EQ. 1 ) .OR. ( flag_vmaxw .EQ. 1 ) .OR. ( flag_hgtmaxw .EQ. 1 ) ) ) THEN
 280          flag_tmaxw   = 0
 281          flag_umaxw   = 0
 282          flag_vmaxw   = 0
 283          flag_hgtmaxw = 0
 284          CALL wrf_debug ( 0 , 'Turning off use of MAX WIND level data in vertical interpolation' )
 285       END IF
 286       IF ( ( config_flags%use_trop_level .EQ. 0 ) .AND. &
 287            ( ( flag_ttrop .EQ. 1 ) .OR. ( flag_utrop .EQ. 1 ) .OR. ( flag_vtrop .EQ. 1 ) .OR. ( flag_hgttrop .EQ. 1 ) ) ) THEN
 288          flag_ttrop   = 0
 289          flag_utrop   = 0
 290          flag_vtrop   = 0
 291          flag_hgttrop = 0
 292          CALL wrf_debug ( 0 , 'Turning off use of TROPOPAUSE level data in vertical interpolation' )
 293       END IF
 294
 295       !   Lake Mask and depth assignment
 296
 297       CALL nl_get_iswater ( grid%id , grid%iswater )
 298       CALL nl_get_islake  ( grid%id , grid%islake )
 299
 300       DO j = jts, MIN(jde-1,jte)
 301          DO i = its, MIN(ide-1,ite)
 302             IF ( grid%lu_index(i,j) .NE. grid%islake ) THEN
 303                grid%lakemask(i,j) = 0
 304             ELSE
 305                grid%lakemask(i,j) = 1
 306             END IF
 307          END DO
 308       END DO
 309
 310       IF ( grid%sf_lake_physics .EQ. 1 ) THEN
 311          grid%lake_depth_flag = flag_lake_depth
 312          IF ( flag_lake_depth .EQ. 0 ) THEN
 313             CALL wrf_message ( " Warning: Please rerun WPS to get lake_depth information for lake model" )
 314
 315          !  Set lake depth over the ocean to be -3 m, and set the lake depth over land to be -2 m.
 316
 317          ELSE
 318             DO j = jts, MIN(jde-1,jte)
 319                DO i = its, MIN(ide-1,ite)
 320                   IF      ( ( grid%lu_index(i,j) .NE. grid%islake ) .AND. ( grid%lu_index(i,j) .NE. grid%iswater ) ) THEN
 321                      grid%lake_depth(i,j) = -2
 322                   ELSE IF   ( grid%lu_index(i,j) .NE. grid%islake ) THEN
 323                      grid%lake_depth(i,j) = -3
 324                   END IF
 325                END DO
 326             END DO
 327          END IF
 328       END IF
 329
 330       grid%bathymetry_flag = flag_bathymetry
 331       IF ( flag_bathymetry .EQ. 0 ) THEN
 332          IF ( grid%shalwater_z0 .EQ. 1 ) THEN
 333              CALL wrf_message ( " Warning: No bathymetry data found for shallow water roughness model." )
 334              IF ( grid%shalwater_depth .LE. 0.0 ) THEN
 335                 CALL wrf_message ( " Warning: shalwater_depth must be greater than 0.0 for WRF to run." )
 336              END IF
 337          END IF
 338          DO j = jts, MIN(jde-1,jte)
 339             DO i = its, MIN(ide-1,ite)
 340                grid%water_depth(i,j) = -4.0
 341             END DO
 342          END DO
 343       ELSE
 344          CALL wrf_message ( " Bathymetry dataset from GEBCO Compilation Group. Please acknowledge the following in presentations and publications: GEBCO Compilation Group (2021) GEBCO 2021 Grid (doi:10.5285/c6612cbe-50b3-0cff-e053-6c86abc09f8f)." )
 345          DO j = jts, MIN(jde-1,jte)
 346             DO i = its, MIN(ide-1,ite)
 347                grid%water_depth(i,j) = grid%bathymetry(i,j)
 348                ! Get depth of lake based on height of water surface:
 349                IF   ( grid%lu_index(i,j) .EQ. grid%islake ) THEN
 350                   grid%water_depth(i,j) = grid%bathymetry(i,j) - grid%ht_gc(i,j)
 351                END IF
 352                ! Depth is positive:
 353                grid%water_depth(i,j) = -grid%water_depth(i,j)
 354                ! Set land cells to -10
 355                IF ( ( grid%lu_index(i,j) .NE. grid%islake ) .AND. ( grid%lu_index(i,j) .NE. grid%iswater ) ) THEN
 356                   grid%water_depth(i,j) = -2.0
 357                ELSE ! Water cells:
 358                   ! Find any water cells with negative (originally positive) values...
 359                   ! ... indicative of mis-match of bathymetry and land mask.
 360                   IF (grid%water_depth(i,j) .LT. 0.1) THEN
 361                      grid%water_depth(i,j) = 0.1
 362                   END IF
 363                END IF
 364             END DO
 365          END DO
 366       END IF
 367
 368       !  Send out a quick message about the time steps based on the map scale factors.
 369
 370       IF ( ( internal_time_loop .EQ. 1 ) .AND. ( grid%id .EQ. 1 ) .AND. &
 371            ( .NOT. config_flags%polar ) ) THEN
 372          max_mf = grid%msft(its,jts)
 373          DO j=jts,MIN(jde-1,jte)
 374             DO i=its,MIN(ide-1,ite)
 375                max_mf = MAX ( max_mf , grid%msft(i,j) )
 376             END DO
 377          END DO
 378 #if ( defined(DM_PARALLEL)  &&   ! defined(STUBMPI) )
 379          max_mf = wrf_dm_max_real ( max_mf )
 380 #endif
 381          WRITE ( a_message , FMT='(A,F5.2,A)' ) 'Max map factor in domain 1 = ',max_mf, &
 382                                                 '. Scale the dt in the model accordingly.'
 383          CALL wrf_message ( a_message )
 384       END IF
 385
 386       !  Check to see if the boundary conditions are set properly in the namelist file.
 387       !  This checks for sufficiency and redundancy.
 388
 389       CALL boundary_condition_check( config_flags, bdyzone, error, grid%id )
 390
 391       !  Some sort of "this is the first time" initialization.  Who knows.
 392
 393       grid%step_number = 0
 394       grid%itimestep=0
 395
 396       !  Pull in the info in the namelist to compare it to the input data.
 397
 398       grid%real_data_init_type = model_config_rec%real_data_init_type
 399
 400       !  To define the base state, we call a USER MODIFIED routine to set the three
 401       !  necessary constants:  p00 (sea level pressure, Pa), t00 (sea level temperature, K),
 402       !  and A (temperature difference, from 1000 mb to 300 mb, K).
 403
 404       CALL const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat )
 405
 406       !  Save these constants to write out in model output file
 407
 408       grid%t00  = t00
 409       grid%p00  = p00
 410       grid%tlp  = a
 411       grid%tiso = tiso
 412       grid%p_strat = p_strat
 413       grid%tlp_strat = a_strat
 414
 415       !  Are there any hold-ups to us bypassing the middle of the domain?  These
 416       !  holdups would be situations where we need data in the middle of the domain.
 417       !  FOr example, if this si the first time period, we need the full domain
 418       !  processed for ICs.  Also, if there is some sort of gridded FDDA turned on, or
 419       !  if the SST update is activated, then we can't just blow off the middle of the
 420       !  domain all willy-nilly.  Other cases of these hold-ups?  Sure - what if the
 421       !  user wants to smooth the CG topo, we need several rows and columns available.
 422       !  What if the lat/lon proj is used, then we need to run a spectral filter on
 423       !  the topo.  Both are killers when trying to ignore data in the middle of the
 424       !  domain.
 425
 426       !  If hold_ups = .F., then there are no hold-ups to excluding the middle
 427       !  domain processing.  If hold_ups = .T., then there are hold-ups, and we
 428       !  must process the middle of the domain.
 429
 430       hold_ups = ( internal_time_loop .EQ. 1 ) .OR. &
 431                  ( config_flags%grid_fdda .NE. 0 ) .OR. &
 432                  ( config_flags%sst_update .EQ. 1 ) .OR. &
 433                  ( config_flags%qna_update .EQ. 1 ) .OR. &
 434                  ( config_flags%all_ic_times ) .OR. &
 435                  ( config_flags%polar )
 436
 437       !  There are a few checks that we need to do when the input data comes in with the middle
 438       !  excluded by WPS.
 439
 440       IF      ( flag_excluded_middle .NE. 0 ) THEN
 441
 442          !  If this time period of data from WPS has the middle excluded, it had better be OK for
 443          !  us to have a hole.
 444
 445          IF ( hold_ups ) THEN
 446             WRITE ( a_message,* ) 'None of the following are allowed to be TRUE : '
 447             CALL wrf_message ( a_message )
 448             WRITE ( a_message,* ) ' ( internal_time_loop .EQ. 1 )               ', ( internal_time_loop .EQ. 1 )
 449             CALL wrf_message ( a_message )
 450             WRITE ( a_message,* ) ' ( config_flags%grid_fdda .NE. 0 )           ', ( config_flags%grid_fdda .NE. 0 )
 451             CALL wrf_message ( a_message )
 452             WRITE ( a_message,* ) ' ( config_flags%sst_update .EQ. 1 )          ', ( config_flags%sst_update .EQ. 1 )
 453             CALL wrf_message ( a_message )
 454             WRITE ( a_message,* ) ' ( config_flags%qna_update .EQ. 1 )          ', ( config_flags%qna_update .EQ. 1 )
 455             CALL wrf_message ( a_message )
 456             WRITE ( a_message,* ) ' ( config_flags%all_ic_times )               ', ( config_flags%all_ic_times )
 457             CALL wrf_message ( a_message )
 458             WRITE ( a_message,* ) ' ( config_flags%smooth_cg_topo )             ', ( config_flags%smooth_cg_topo )
 459             CALL wrf_message ( a_message )
 460             WRITE ( a_message,* ) ' ( config_flags%polar )                      ', ( config_flags%polar )
 461             CALL wrf_message ( a_message )
 462
 463             WRITE ( a_message,* ) 'Problems, we cannot have excluded middle data from WPS'
 464             CALL wrf_error_fatal ( a_message )
 465          END IF
 466
 467          !  Make sure that the excluded middle data from metgrid is "wide enough".  We only have to check
 468          !  when the excluded middle was actually used in WPS.
 469
 470          IF ( config_flags%spec_bdy_width .GT. flag_excluded_middle ) THEN
 471             WRITE ( a_message,* ) 'The WRF &bdy_control namelist.input spec_bdy_width = ', config_flags%spec_bdy_width
 472             CALL wrf_message ( a_message )
 473             WRITE ( a_message,* ) 'The WPS &metgrid namelist.wps process_only_bdy width = ',flag_excluded_middle
 474             CALL wrf_message ( a_message )
 475             WRITE ( a_message,* ) 'WPS process_only_bdy must be >= WRF spec_bdy_width'
 476             CALL wrf_error_fatal ( a_message )
 477          END IF
 478       END IF
 479       em_width = config_flags%spec_bdy_width
 480
 481       !  We need to find if there are any valid non-excluded-middle points in this
 482       !  tile.  If so, then we need to hang on to a valid i,j location.
 483
 484       any_valid_points = .false.
 485       find_valid : DO j = jts,jte
 486          DO i = its,ite
 487             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 488             any_valid_points = .true.
 489             i_valid = i
 490             j_valid = j
 491             EXIT find_valid
 492          END DO
 493       END DO find_valid
 494
 495       !  Replace traditional seaice field with optional seaice (AFWA source)
 496
 497       IF ( flag_icefrac .EQ. 1 ) THEN
 498          DO j=jts,MIN(jde-1,jte)
 499             DO i=its,MIN(ide-1,ite)
 500                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 501                grid%xice(i,j) = grid%icefrac_gc(i,j)
 502             END DO
 503          END DO
 504       END IF
 505
 506       !  Replace traditional seaice field with optional seaice percent (AFWA source)
 507
 508       IF ( flag_icepct .EQ. 1 ) THEN
 509          DO j=jts,MIN(jde-1,jte)
 510             DO i=its,MIN(ide-1,ite)
 511                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 512                grid%xice(i,j) = grid%icepct(i,j)/100.
 513             END DO
 514          END DO
 515       END IF
 516
 517       !  Fix the snow (water equivalent depth, kg/m^2) and the snowh (physical snow
 518       !  depth, m) fields.
 519
 520       IF      ( ( flag_snow .EQ. 0 ) .AND. ( flag_snowh .EQ. 0 ) ) THEN
 521          DO j=jts,MIN(jde-1,jte)
 522             DO i=its,MIN(ide-1,ite)
 523                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 524                grid%snow(i,j)  = 0.
 525                grid%snowh(i,j) = 0.
 526             END DO
 527          END DO
 528
 529       ELSE IF ( ( flag_snow .EQ. 0 ) .AND. ( flag_snowh .EQ. 1 ) ) THEN
 530          DO j=jts,MIN(jde-1,jte)
 531             DO i=its,MIN(ide-1,ite)
 532 !              ( m -> kg/m^2 )  & ( reduce to liquid, 5:1 ratio )
 533                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 534                grid%snow(i,j)  = grid%snowh(i,j) * 1000. / 5.
 535             END DO
 536          END DO
 537
 538       ELSE IF ( ( flag_snow .EQ. 1 ) .AND. ( flag_snowh .EQ. 0 ) ) THEN
 539          DO j=jts,MIN(jde-1,jte)
 540             DO i=its,MIN(ide-1,ite)
 541 !              ( kg/m^2 -> m)  & ( liquid to snow depth, 5:1 ratio )
 542                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 543                grid%snowh(i,j) = grid%snow(i,j) / 1000. * 5.
 544             END DO
 545          END DO
 546
 547       END IF
 548
 549       !  For backward compatibility, we might need to assign the map factors from
 550       !  what they were, to what they are.
 551
 552       IF      ( ( config_flags%polar ) .AND. ( flag_mf_xy .EQ. 1 ) ) THEN
 553          DO j=max(jds+1,jts),min(jde-1,jte)
 554             DO i=its,min(ide-1,ite)
 555                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 556                grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j)
 557             END DO
 558          END DO
 559          IF(jts == jds) THEN
 560             DO i=its,ite
 561                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 562                grid%msfvx(i,jts) = 0.
 563                grid%msfvx_inv(i,jts) = 0.
 564             END DO
 565          END IF
 566          IF(jte == jde) THEN
 567             DO i=its,ite
 568                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 569                grid%msfvx(i,jte) = 0.
 570                grid%msfvx_inv(i,jte) = 0.
 571             END DO
 572          END IF
 573       ELSE IF ( ( .NOT. config_flags%polar ) .AND. ( flag_mf_xy .EQ. 1 ) ) THEN
 574          IF ( grid%msfvx(its,jts) .EQ. 0 ) THEN
 575             CALL wrf_error_fatal ( 'Maybe this is a global domain, but the polar flag was not set in the bdy_control namelist.' )
 576          END IF
 577          DO j=jts,min(jde,jte)
 578             DO i=its,min(ide-1,ite)
 579                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 580                grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j)
 581             END DO
 582          END DO
 583       ELSE IF ( ( config_flags%polar ) .AND. ( flag_mf_xy .NE. 1 ) ) THEN
 584          CALL wrf_error_fatal ( 'Older metgrid data cannot initialize a global domain' )
 585       ENDIF
 586
 587       !  Check to see what available surface temperatures we have.
 588
 589       IF ( flag_tavgsfc .EQ. 1 ) THEN
 590          we_have_tavgsfc = .TRUE.
 591       ELSE
 592          we_have_tavgsfc = .FALSE.
 593       END IF
 594
 595       IF ( flag_tsk     .EQ. 1 ) THEN
 596          we_have_tsk     = .TRUE.
 597       ELSE
 598          we_have_tsk     = .FALSE.
 599       END IF
 600
 601       IF ( config_flags%use_tavg_for_tsk ) THEN
 602          IF ( we_have_tsk .OR. we_have_tavgsfc ) THEN
 603            !  we are OK
 604          ELSE
 605             CALL wrf_error_fatal ( 'We either need TSK or TAVGSFC, verify these fields are coming from WPS' )
 606          END IF
 607
 608          !  Since we require a skin temperature in the model, we can use the average 2-m temperature if provided.
 609
 610          IF ( we_have_tavgsfc ) THEN
 611             DO j=jts,min(jde,jte)
 612                DO i=its,min(ide-1,ite)
 613                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 614                   grid%tsk(i,j) = grid%tavgsfc(i,j)
 615                END DO
 616             END DO
 617          END IF
 618       END IF
 619
 620       IF (config_flags%slucm_distributed_drag) THEN
 621         CALL wrf_message('Adding zero-plane displacement height to topography')
 622         DO j = jts, MIN(jde - 1, jte)
 623         DO i = its, MIN(ide - 1, ite)
 624           IF (grid%zd_urb2d(i, j) > 0) grid%ht_gc(i, j) = grid%ht_gc(i, j) + grid%zd_urb2d(i, j)
 625         END DO
 626         END DO
 627       END IF
 628
 629       !  Is there any vertical interpolation to do?  The "old" data comes in on the correct
 630       !  vertical locations already.
 631
 632       IF ( flag_metgrid .EQ. 1 ) THEN  !   <----- START OF VERTICAL INTERPOLATION PART ---->
 633
 634          num_metgrid_levels = grid%num_metgrid_levels
 635
 636          IF ( config_flags%nest_interp_coord .EQ. 1 ) THEN
 637
 638             !  At the location of maximum pressure in the column, get the temperature and height.  These
 639             !  will be written out and could be used for vertical interpolation - to avoid extrapolation.
 640             !  Hey, we can also do minimum values, too.
 641
 642             DO j=jts,jte
 643                DO i=its,ite
 644                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 645                   grid%max_p(i,j) = grid%p_gc(i,1,j)
 646                   k_max_p = 1
 647                   IF      ( grid%p_gc(i,2,j) .GT. grid%max_p(i,j) ) THEN
 648                      grid%max_p(i,j) = grid%p_gc(i,2,j)
 649                      k_max_p = 2
 650                   ELSE IF ( grid%p_gc(i,num_metgrid_levels,j) .GT. grid%max_p(i,j) ) THEN
 651                      grid%max_p(i,j) = grid%p_gc(i,num_metgrid_levels,j)
 652                      k_max_p = num_metgrid_levels
 653                   END IF
 654                   grid%t_max_p(i,j) = grid%t_gc(i,k_max_p,j)
 655                   grid%ght_max_p(i,j) = grid%ght_gc(i,k_max_p,j)
 656
 657                   grid%min_p(i,j) = grid%p_gc(i,num_metgrid_levels,j)
 658                   k_min_p = num_metgrid_levels
 659                   IF      ( grid%p_gc(i,2,j) .LT. grid%min_p(i,j) ) THEN
 660                      grid%min_p(i,j) = grid%p_gc(i,2,j)
 661                      k_min_p = 2
 662                   END IF
 663                   grid%t_min_p(i,j) = grid%t_gc(i,k_min_p,j)
 664                   grid%ght_min_p(i,j) = grid%ght_gc(i,k_min_p,j)
 665                END DO
 666             END DO
 667          END IF
 668
 669          !  If this is data from the PINTERP program, it is emulating METGRID output.
 670          !  One of the caveats of this data is the way that the vertical structure is
 671          !  handled.  We take the k=1 level and toss it (it is disposable), and we
 672          !  swap in the surface data.  This is done for all of the 3d fields about
 673          !  which we show some interest: u, v, t, rh, ght, and p.  For u, v, and rh,
 674          !  we assume no interesting vertical structure, and just assign the 1000 mb
 675          !  data.  We directly use the 2-m temp for surface temp.  We use the surface
 676          !  pressure field and the topography elevation for the lowest level of
 677          !  pressure and height, respectively.
 678
 679          IF ( flag_pinterp .EQ. 1 ) THEN
 680
 681             WRITE ( a_message , * ) 'Data from P_INTERP program, filling k=1 level with artificial surface fields.'
 682             CALL wrf_message ( a_message )
 683             DO j=jts,jte
 684                DO i=its,ite
 685                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 686                   grid%u_gc(i,1,j) = grid%u_gc(i,2,j)
 687                   grid%v_gc(i,1,j) = grid%v_gc(i,2,j)
 688                   grid%rh_gc(i,1,j) = grid%rh_gc(i,2,j)
 689                   grid%t_gc(i,1,j) = grid%t2(i,j)
 690                   grid%ght_gc(i,1,j) = grid%ht(i,j)
 691                   grid%p_gc(i,1,j) = grid%psfc(i,j)
 692                END DO
 693             END DO
 694             flag_psfc = 0
 695
 696          END IF
 697
 698          !  Variables that are named differently between SI and WPS.
 699
 700          DO j = jts, MIN(jte,jde-1)
 701             DO i = its, MIN(ite,ide-1)
 702                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 703                grid%tsk(i,j) = grid%tsk_gc(i,j)
 704                grid%tmn(i,j) = grid%tmn_gc(i,j)
 705                grid%xlat(i,j) = grid%xlat_gc(i,j)
 706                grid%xlong(i,j) = grid%xlong_gc(i,j)
 707                grid%ht(i,j) = grid%ht_gc(i,j)
 708             END DO
 709          END DO
 710
 711          !  A user could request that the most coarse grid has the
 712          !  topography along the outer boundary smoothed.  This smoothing
 713          !  is similar to the coarse/nest interface.  The outer rows and
 714          !  cols come from the existing large scale topo, and then the
 715          !  next several rows/cols are a linear ramp of the large scale
 716          !  model and the hi-res topo from WPS.  We only do this for the
 717          !  coarse grid since we are going to make the interface consistent
 718          !  in the model betwixt the CG and FG domains.
 719
 720          !  An important point is to inform the user if their request cannot
 721          !  be satisfied. Do not skip over this quietly.
 722
 723          IF ( ( config_flags%smooth_cg_topo ) .AND. &
 724               ( internal_time_loop .EQ. 1 ) .AND. &
 725               ( grid%id .EQ. 1 ) .AND. &
 726               ( flag_soilhgt .NE. 1) ) THEN
 727             CALL wrf_message    (' --- ERROR: NML option smooth_cg_topo=T')
 728             CALL wrf_message    ('            But found no soil elevation / terrain / topography data in metgrid files')
 729             CALL wrf_message    ('            The field SOILHGT is required when smoothing the CG topography on d01')
 730             CALL wrf_error_fatal('            If using ERA5 data, possibly need to add more time invariant fields')
 731          END IF
 732
 733          IF ( ( config_flags%smooth_cg_topo ) .AND. &
 734               ( internal_time_loop .EQ. 1 ) .AND. &
 735               ( grid%id .EQ. 1 ) .AND. &
 736               ( flag_soilhgt .EQ. 1) ) THEN
 737             CALL blend_terrain ( grid%toposoil  , grid%ht , &
 738                                  ids , ide , jds , jde , 1   , 1   , &
 739                                  ims , ime , jms , jme , 1   , 1   , &
 740                                  ips , ipe , jps , jpe , 1   , 1   )
 741             DO j = jts, MIN(jte,jde-1)
 742                DO i = its, MIN(ite,ide-1)
 743                   grid%ht_smooth(i,j) = grid%ht(i,j)
 744                END DO
 745             END DO
 746
 747          ELSE IF ( ( config_flags%smooth_cg_topo ) .AND. &
 748               ( internal_time_loop .NE. 1 ) .AND. &
 749               ( grid%id .EQ. 1 ) .AND. &
 750               ( flag_soilhgt .EQ. 1) ) THEN
 751             DO j = jts, MIN(jte,jde-1)
 752                DO i = its, MIN(ite,ide-1)
 753                   grid%ht(i,j) = grid%ht_smooth(i,j)
 754                END DO
 755             END DO
 756
 757          END IF
 758
 759          !  Filter the input topography if this is a global domain.
 760
 761          IF ( ( config_flags%polar ) .AND. ( grid%fft_filter_lat .GT. 90 ) ) THEN
 762             CALL wrf_error_fatal ( 'If the polar boundary condition is used, then fft_filter_lat must be set in namelist.input' )
 763          END IF
 764
 765          IF ( ( config_flags%map_proj .EQ. PROJ_CASSINI ) .AND. ( config_flags%polar ) ) THEN
 766 #if 1
 767             dclat = 90./REAL(jde-jds) !(0.5 * 180/ny)
 768             DO j = jts, MIN(jte,jde-1)
 769               DO k = kts, kte
 770                  DO i = its, MIN(ite,ide-1)
 771                     grid%t_2(i,k,j) = 1.
 772                  END DO
 773               END DO
 774               DO i = its, MIN(ite,ide-1)
 775                  grid%t_2(i,1,j) = grid%ht(i,j)
 776                  grid%sr(i,j) = grid%ht(i,j)
 777               END DO
 778             END DO
 779 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
 780 ! WARNING:  this might present scaling issues on very large numbers of processors
 781      ALLOCATE( clat_glob(ids:ide,jds:jde) )
 782
 783      CALL wrf_patch_to_global_real ( grid%clat, clat_glob, grid%domdesc, 'xy', 'xy', &
 784                                      ids, ide, jds, jde, 1, 1, &
 785                                      ims, ime, jms, jme, 1, 1, &
 786                                      its, ite, jts, jte, 1, 1 )
 787
 788      CALL wrf_dm_bcast_real ( clat_glob , (ide-ids+1)*(jde-jds+1) )
 789
 790      grid%clat_xxx(ipsx:ipex,jpsx:jpex) = clat_glob(ipsx:ipex,jpsx:jpex)
 791
 792      find_j_index_of_fft_filter : DO j = jds , jde-1
 793         IF ( ABS(clat_glob(ids,j)) .LE. config_flags%fft_filter_lat ) THEN
 794            j_save = j
 795            EXIT find_j_index_of_fft_filter
 796         END IF
 797      END DO find_j_index_of_fft_filter
 798
 799      CALL wrf_patch_to_global_real ( grid%msft, clat_glob, grid%domdesc, 'xy', 'xy', &
 800                                      ids, ide, jds, jde, 1, 1, &
 801                                      ims, ime, jms, jme, 1, 1, &
 802                                      its, ite, jts, jte, 1, 1 )
 803
 804      CALL wrf_dm_bcast_real ( clat_glob , (ide-ids+1)*(jde-jds+1) )
 805
 806      grid%mf_fft = clat_glob(ids,j_save)
 807
 808      grid%mf_xxx(ipsx:ipex,jpsx:jpex) = clat_glob(ipsx:ipex,jpsx:jpex)
 809
 810      DEALLOCATE( clat_glob )
 811 #else
 812      find_j_index_of_fft_filter : DO j = jds , jde-1
 813         IF ( ABS(grid%clat(ids,j)) .LE. config_flags%fft_filter_lat ) THEN
 814            j_save = j
 815            EXIT find_j_index_of_fft_filter
 816         END IF
 817      END DO find_j_index_of_fft_filter
 818      grid%mf_fft = grid%msft(ids,j_save)
 819 #endif
 820
 821          CALL pxft ( grid=grid                                              &
 822                ,lineno=__LINE__                                             &
 823                ,flag_uv            = 0                                      &
 824                ,flag_rurv          = 0                                      &
 825                ,flag_wph           = 0                                      &
 826                ,flag_ww            = 0                                      &
 827                ,flag_t             = 1                                      &
 828                ,flag_mu            = 0                                      &
 829                ,flag_mut           = 0                                      &
 830                ,flag_moist         = 0                                      &
 831                ,flag_chem          = 0                                      &
 832                ,flag_tracer        = 0                                      &
 833                ,flag_scalar        = 0                                      &
 834                ,actual_distance_average  = .TRUE.                           &
 835                ,pos_def            = .FALSE.                                &
 836                ,swap_pole_with_next_j = .FALSE.                             &
 837                ,moist=moist,chem=chem,tracer=tracer,scalar=scalar           &
 838                ,fft_filter_lat = config_flags%fft_filter_lat                &
 839                ,dclat = dclat                                               &
 840                ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde             &
 841                ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme             &
 842                ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe             &
 843                ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
 844                ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
 845
 846             DO j = jts, MIN(jte,jde-1)
 847               DO i = its, MIN(ite,ide-1)
 848                  grid%ht(i,j) = grid%t_2(i,1,j)
 849                  grid%sr(i,j) = grid%sr(i,j) - grid%ht(i,j)
 850               END DO
 851             END DO
 852
 853 #else
 854 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
 855
 856             !  We stick the topo and map fac in an unused 3d array. The map scale
 857             !  factor and computational latitude are passed along for the ride
 858             !  (part of the transpose process - we only do 3d arrays) to determine
 859             !  "how many" values are used to compute the mean.  We want a number
 860             !  that is consistent with the original grid resolution.
 861
 862             DO j = jts, MIN(jte,jde-1)
 863               DO k = kts, kte
 864                  DO i = its, MIN(ite,ide-1)
 865                     grid%t_init(i,k,j) = 1.
 866                  END DO
 867               END DO
 868               DO i = its, MIN(ite,ide-1)
 869                  grid%t_init(i,1,j) = grid%ht(i,j)
 870                  grid%t_init(i,2,j) = grid%msftx(i,j)
 871                  grid%t_init(i,3,j) = grid%clat(i,j)
 872               END DO
 873             END DO
 874
 875 # include "XPOSE_POLAR_FILTER_TOPO_z2x.inc"
 876
 877             !  Retrieve the 2d arrays for topo, map factors, and the
 878             !  computational latitude.
 879
 880             DO j = jpsx, MIN(jpex,jde-1)
 881               DO i = ipsx, MIN(ipex,ide-1)
 882                  grid%ht_xxx(i,j)   = grid%t_xxx(i,1,j)
 883                  grid%mf_xxx(i,j)   = grid%t_xxx(i,2,j)
 884                  grid%clat_xxx(i,j) = grid%t_xxx(i,3,j)
 885               END DO
 886             END DO
 887
 888             !  Get a mean topo field that is consistent with the grid
 889             !  distance on each computational latitude loop.
 890
 891             CALL filter_topo ( grid%ht_xxx , grid%clat_xxx , grid%mf_xxx , &
 892                                grid%fft_filter_lat , grid%mf_fft , &
 893                                .FALSE. , .FALSE. , &
 894                                ids, ide, jds, jde, 1 , 1 , &
 895                                imsx, imex, jmsx, jmex, 1, 1, &
 896                                ipsx, ipex, jpsx, jpex, 1, 1 )
 897
 898             !  Stick the filtered topo back into the dummy 3d array to
 899             !  transpose it back to "all z on a patch".
 900
 901             DO j = jpsx, MIN(jpex,jde-1)
 902               DO i = ipsx, MIN(ipex,ide-1)
 903                  grid%t_xxx(i,1,j) = grid%ht_xxx(i,j)
 904               END DO
 905             END DO
 906
 907 # include "XPOSE_POLAR_FILTER_TOPO_x2z.inc"
 908
 909             !  Get the un-transposed topo data.
 910
 911             DO j = jts, MIN(jte,jde-1)
 912               DO i = its, MIN(ite,ide-1)
 913                  grid%ht(i,j) = grid%t_init(i,1,j)
 914               END DO
 915             END DO
 916 #else
 917             CALL filter_topo ( grid%ht , grid%clat , grid%msftx , &
 918                                grid%fft_filter_lat , grid%mf_fft , &
 919                                .FALSE. , .FALSE. , &
 920                                ids, ide, jds, jde, 1,1,           &
 921                                ims, ime, jms, jme, 1,1,           &
 922                                its, ite, jts, jte, 1,1 )
 923 #endif
 924 #endif
 925          ELSE IF ( ( config_flags%map_proj .NE. PROJ_CASSINI ) .AND. ( config_flags%polar ) ) THEN
 926             WRITE ( a_message,* ) 'A global domain (polar = true) requires the Cassini projection'
 927             CALL wrf_error_fatal ( a_message )
 928          END IF
 929
 930          !  If we have any input low-res surface pressure, we store it.
 931
 932          IF ( flag_psfc .EQ. 1 ) THEN
 933             DO j = jts, MIN(jte,jde-1)
 934               DO i = its, MIN(ite,ide-1)
 935                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 936                  grid%psfc_gc(i,j) = grid%psfc(i,j)
 937                  grid%p_gc(i,1,j) = grid%psfc(i,j)
 938               END DO
 939             END DO
 940          END IF
 941
 942          !  If we have the low-resolution surface elevation, stick that in the
 943          !  "input" locations of the 3d height.  We still have the "hi-res" topo
 944          !  stuck in the grid%ht array.  The grid%landmask if test is required as some sources
 945          !  have ZERO elevation over water (thank you very much).
 946
 947          IF ( flag_soilhgt .EQ. 1) THEN
 948             DO j = jts, MIN(jte,jde-1)
 949                DO i = its, MIN(ite,ide-1)
 950 !                 IF ( grid%landmask(i,j) .GT. 0.5 ) THEN
 951                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 952                      grid%ght_gc(i,1,j) = grid%toposoil(i,j)
 953                      grid%ht_gc(i,j)= grid%toposoil(i,j)
 954 !                 END IF
 955                END DO
 956            END DO
 957          END IF
 958
 959          !  The number of vertical levels in the input data.  There is no staggering for
 960          !  different variables.
 961
 962          num_metgrid_levels = grid%num_metgrid_levels
 963
 964          !  For AFWA UM data, swap incoming extra (theta-based) pressure with the standardly
 965          !  named (rho-based) pressure.
 966
 967          IF ( flag_ptheta .EQ. 1 ) THEN
 968             DO j = jts, MIN(jte,jde-1)
 969                DO k = 1 , num_metgrid_levels
 970                   DO i = its, MIN(ite,ide-1)
 971                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 972                      ptemp = grid%p_gc(i,k,j)
 973                      grid%p_gc(i,k,j) = grid%prho_gc(i,k,j)
 974                      grid%prho_gc(i,k,j) = ptemp
 975                   END DO
 976                END DO
 977             END DO
 978          END IF
 979
 980          !  For UM data, the "surface" and the "first hybrid" level for the theta-level data fields are the same.
 981          !  Average the surface (k=1) and the second hybrid level (k=num_metgrid_levels-1) to get the first hybrid
 982          !  layer.  We only do this for the theta-level data: pressure, temperature, specific humidity, and
 983          !  geopotential height (i.e. we do not modify u, v, or the rho-based pressure).
 984
 985          IF ( ( flag_ptheta .EQ. 1 ) .OR. ( flag_prho .EQ. 1 ) ) THEN
 986             DO j = jts, MIN(jte,jde-1)
 987                DO i = its, MIN(ite,ide-1)
 988                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 989                   grid%  p_gc(i,num_metgrid_levels,j) = ( grid%  p_gc(i,1,j) + grid%  p_gc(i,num_metgrid_levels-1,j) ) * 0.5
 990                   grid%  t_gc(i,num_metgrid_levels,j) = ( grid%  t_gc(i,1,j) + grid%  t_gc(i,num_metgrid_levels-1,j) ) * 0.5
 991                   grid%ght_gc(i,num_metgrid_levels,j) = ( grid%ght_gc(i,1,j) + grid%ght_gc(i,num_metgrid_levels-1,j) ) * 0.5
 992                END DO
 993             END DO
 994
 995             IF ( grid%sh_gc(its,1,jts) .LT. 0 ) THEN
 996                DO j = jts, MIN(jte,jde-1)
 997                   DO i = its, MIN(ite,ide-1)
 998                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
 999                      grid% sh_gc(i,1,j) = 2. * grid% sh_gc(i,num_metgrid_levels,j) - grid% sh_gc(i,num_metgrid_levels-1,j)
1000                   END DO
1001                END DO
1002             END IF
1003             IF ( grid%cl_gc(its,1,jts) .LT. 0 ) THEN
1004                DO j = jts, MIN(jte,jde-1)
1005                   DO i = its, MIN(ite,ide-1)
1006                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1007                      grid% cl_gc(i,1,j) = 2. * grid% cl_gc(i,num_metgrid_levels,j) - grid% cl_gc(i,num_metgrid_levels-1,j)
1008                   END DO
1009                END DO
1010             END IF
1011             IF ( grid%cf_gc(its,1,jts) .LT. 0 ) THEN
1012                DO j = jts, MIN(jte,jde-1)
1013                   DO i = its, MIN(ite,ide-1)
1014                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1015                      grid% cf_gc(i,1,j) = 2. * grid% cf_gc(i,num_metgrid_levels,j) - grid% cf_gc(i,num_metgrid_levels-1,j)
1016                   END DO
1017                END DO
1018             END IF
1019          END IF
1020
1021          !  For UM data, the soil moisture comes in as kg / m^2. Divide by 1000 and layer thickness to get m^3 / m^3.
1022
1023          IF ( flag_prho .EQ. 1 ) THEN
1024
1025             levels(1) = 0.
1026             levels(2) = ( 2. * sm_levels_input(1) )
1027             DO k = 2 , num_sm_levels_input
1028                levels(k+1) = ( 2. * sm_levels_input(k) ) - levels(k)
1029             END DO
1030             DO k = 1 , num_sm_levels_input
1031                thickness(k) = ( levels(k+1) - levels(k) ) / 100.
1032             END DO
1033
1034             DO j = jts, MIN(jte,jde-1)
1035                DO k = 1 , num_sm_levels_input
1036                   DO i = its, MIN(ite,ide-1)
1037                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1038                      sm_input(i,k+1,j) = MAX ( 0. , sm_input(i,k+1,j) / 1000. / thickness(k) )
1039                   END DO
1040                END DO
1041             END DO
1042          END IF
1043
1044          IF ( any_valid_points ) THEN
1045          !  Check for and semi-fix missing surface fields.
1046
1047          IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN
1048             k = 2
1049          ELSE
1050             k = num_metgrid_levels
1051          END IF
1052
1053          IF ( grid%t_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN
1054             DO j = jts, MIN(jte,jde-1)
1055                DO i = its, MIN(ite,ide-1)
1056                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1057                   grid%t_gc(i,1,j) = grid%t_gc(i,k,j)
1058                END DO
1059             END DO
1060             config_flags%use_surface = .FALSE.
1061             grid%use_surface = .FALSE.
1062             WRITE ( a_message , * ) 'Missing surface temp, replaced with closest level, use_surface set to false.'
1063             CALL wrf_message ( a_message )
1064          END IF
1065
1066          IF ( grid%rh_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN
1067             DO j = jts, MIN(jte,jde-1)
1068                DO i = its, MIN(ite,ide-1)
1069                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1070                   grid%rh_gc(i,1,j) = grid%rh_gc(i,k,j)
1071                END DO
1072             END DO
1073             config_flags%use_surface = .FALSE.
1074             grid%use_surface = .FALSE.
1075             WRITE ( a_message , * ) 'Missing surface RH, replaced with closest level, use_surface set to false.'
1076             CALL wrf_message ( a_message )
1077          END IF
1078
1079          IF ( grid%u_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN
1080             DO j = jts, MIN(jte,jde-1)
1081                DO i = its, ite
1082                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1083                   grid%u_gc(i,1,j) = grid%u_gc(i,k,j)
1084                END DO
1085             END DO
1086             config_flags%use_surface = .FALSE.
1087             grid%use_surface = .FALSE.
1088             WRITE ( a_message , * ) 'Missing surface u wind, replaced with closest level, use_surface set to false.'
1089             CALL wrf_message ( a_message )
1090          END IF
1091
1092          IF ( grid%v_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN
1093             DO j = jts, jte
1094                DO i = its, MIN(ite,ide-1)
1095                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1096                   grid%v_gc(i,1,j) = grid%v_gc(i,k,j)
1097                END DO
1098             END DO
1099             config_flags%use_surface = .FALSE.
1100             grid%use_surface = .FALSE.
1101             WRITE ( a_message , * ) 'Missing surface v wind, replaced with closest level, use_surface set to false.'
1102             CALL wrf_message ( a_message )
1103          END IF
1104
1105          !  Compute the mixing ratio from the input relative humidity.
1106
1107          IF ( ( flag_qv .NE. 1 ) .AND. ( flag_sh .NE. 1 ) ) THEN
1108             IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN
1109                k = 2
1110             ELSE
1111                k = num_metgrid_levels
1112             END IF
1113             config_flags%use_sh_qv = .FALSE.
1114
1115             IF      ( config_flags%rh2qv_method .eq. 1 ) THEN
1116                CALL rh_to_mxrat1(grid%rh_gc, grid%t_gc, grid%p_gc, grid%qv_gc ,         &
1117                                  config_flags%rh2qv_wrt_liquid ,                        &
1118                                  config_flags%qv_max_p_safe ,                           &
1119                                  config_flags%qv_max_flag , config_flags%qv_max_value , &
1120                                  config_flags%qv_min_p_safe ,                           &
1121                                  config_flags%qv_min_flag , config_flags%qv_min_value , &
1122                                  ids , ide , jds , jde , 1   , num_metgrid_levels ,     &
1123                                  ims , ime , jms , jme , 1   , num_metgrid_levels ,     &
1124                                  its , ite , jts , jte , 1   , num_metgrid_levels )
1125             ELSE IF ( config_flags%rh2qv_method .eq. 2 ) THEN
1126                CALL rh_to_mxrat2(grid%rh_gc, grid%t_gc, grid%p_gc, grid%qv_gc ,         &
1127                                  config_flags%rh2qv_wrt_liquid ,                        &
1128                                  config_flags%qv_max_p_safe ,                           &
1129                                  config_flags%qv_max_flag , config_flags%qv_max_value , &
1130                                  config_flags%qv_min_p_safe ,                           &
1131                                  config_flags%qv_min_flag , config_flags%qv_min_value , &
1132                                  ids , ide , jds , jde , 1   , num_metgrid_levels ,     &
1133                                  ims , ime , jms , jme , 1   , num_metgrid_levels ,     &
1134                                  its , ite , jts , jte , 1   , num_metgrid_levels )
1135             END IF
1136
1137
1138          ELSE IF ( flag_sh .EQ. 1 ) THEN
1139             IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN
1140                k = 2
1141             ELSE
1142                k = num_metgrid_levels
1143             END IF
1144             IF ( grid%sh_gc(i_valid,kts,j_valid) .LT. 1.e-6 ) THEN
1145                DO j = jts, MIN(jte,jde-1)
1146                   DO i = its, MIN(ite,ide-1)
1147                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1148                      grid%sh_gc(i,1,j) = grid%sh_gc(i,k,j)
1149                   END DO
1150                END DO
1151             END IF
1152
1153             DO j = jts, MIN(jte,jde-1)
1154                DO k = 1 , num_metgrid_levels
1155                   DO i = its, MIN(ite,ide-1)
1156                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1157                      grid%qv_gc(i,k,j) = grid%sh_gc(i,k,j) /( 1. - grid%sh_gc(i,k,j) )
1158                      sat_vap_pres_mb = 0.6112*10.*EXP(17.67*(grid%t_gc(i,k,j)-273.15)/(grid%t_gc(i,k,j)-29.65))
1159                      vap_pres_mb = grid%qv_gc(i,k,j) * grid%p_gc(i,k,j)/100. / (grid%qv_gc(i,k,j) + 0.622 )
1160                      IF ( sat_vap_pres_mb .GT. 0 ) THEN
1161                         grid%rh_gc(i,k,j) = ( vap_pres_mb / sat_vap_pres_mb ) * 100.
1162                      ELSE
1163                         grid%rh_gc(i,k,j) = 0.
1164                      END IF
1165                   END DO
1166                END DO
1167             END DO
1168
1169          ELSE IF ( flag_qv .EQ. 1 ) THEN
1170             IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN
1171                k = 2
1172             ELSE
1173                k = num_metgrid_levels
1174             END IF
1175
1176             DO j = jts, MIN(jte,jde-1)
1177                DO k = 1 , num_metgrid_levels
1178                   DO i = its, MIN(ite,ide-1)
1179                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1180                      sat_vap_pres_mb = 0.6112*10.*EXP(17.67*(grid%t_gc(i,k,j)-273.15)/(grid%t_gc(i,k,j)-29.65))
1181                      vap_pres_mb = grid%qv_gc(i,k,j) * grid%p_gc(i,k,j)/100. / (grid%qv_gc(i,k,j) + 0.622 )
1182                      IF ( sat_vap_pres_mb .GT. 0 ) THEN
1183                         grid%rh_gc(i,k,j) = ( vap_pres_mb / sat_vap_pres_mb ) * 100.
1184                      ELSE
1185                         grid%rh_gc(i,k,j) = 0.
1186                      END IF
1187                   END DO
1188                END DO
1189             END DO
1190
1191          END IF
1192
1193          !  Some data sets do not provide a 3d geopotential height field.
1194          !  This calculation is more accurate if the data is bottom-up.
1195
1196          IF ( grid%ght_gc(i_valid,grid%num_metgrid_levels/2,j_valid) .LT. 1 ) THEN
1197             DO j = jts, MIN(jte,jde-1)
1198                DO k = kts+1 , grid%num_metgrid_levels
1199                   DO i = its, MIN(ite,ide-1)
1200                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1201                      grid%ght_gc(i,k,j) = grid%ght_gc(i,k-1,j) - &
1202                         R_d / g * 0.5 * ( grid%t_gc(i,k  ,j) * ( 1 + 0.608 * grid%qv_gc(i,k  ,j) ) +   &
1203                                           grid%t_gc(i,k-1,j) * ( 1 + 0.608 * grid%qv_gc(i,k-1,j) ) ) * &
1204                         LOG ( grid%p_gc(i,k,j) / grid%p_gc(i,k-1,j) )
1205                   END DO
1206                END DO
1207             END DO
1208          END IF
1209
1210          !  If the pressure levels in the middle of the atmosphere are upside down, then
1211          !  this is hybrid data.  Computing the new surface pressure should use sfcprs2.
1212
1213          IF ( grid%p_gc(i_valid,num_metgrid_levels/2,j_valid) .LT. grid%p_gc(i_valid,num_metgrid_levels/2+1,j_valid) ) THEN
1214             config_flags%sfcp_to_sfcp = .TRUE.
1215          END IF
1216          END IF
1217
1218          !  Assign surface fields with original input values.  If this is hybrid data,
1219          !  the values are not exactly representative.  However - this is only for
1220          !  plotting purposes and such at the 0h of the forecast, so we are not all that
1221          !  worried.
1222
1223          DO j = jts, min(jde-1,jte)
1224             DO i = its, min(ide,ite)
1225                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1226                grid%u10(i,j)=grid%u_gc(i,1,j)
1227             END DO
1228          END DO
1229
1230          DO j = jts, min(jde,jte)
1231             DO i = its, min(ide-1,ite)
1232                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1233                grid%v10(i,j)=grid%v_gc(i,1,j)
1234             END DO
1235          END DO
1236
1237          DO j = jts, min(jde-1,jte)
1238             DO i = its, min(ide-1,ite)
1239                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1240                grid%t2(i,j)=grid%t_gc(i,1,j)
1241             END DO
1242          END DO
1243
1244          IF ( flag_qv .EQ. 1 ) THEN
1245             DO j = jts, min(jde-1,jte)
1246                DO i = its, min(ide-1,ite)
1247                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1248                   grid%q2(i,j)=grid%qv_gc(i,1,j)
1249                END DO
1250             END DO
1251          END IF
1252
1253          IF ( flag_sh .EQ. 1 ) THEN
1254             DO j = jts, min(jde-1,jte)
1255                DO i = its, min(ide-1,ite)
1256                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1257                   grid%q2(i,j)=grid%qv_gc(i,1,j)
1258                END DO
1259             END DO
1260          END IF
1261
1262          !  The requested ptop for real data cases.
1263
1264          p_top_requested = grid%p_top_requested
1265
1266          !  Compute the top pressure, grid%p_top.  For isobaric data, this is just the
1267          !  top level.  For the generalized vertical coordinate data, we find the
1268          !  max pressure on the top level.  We have to be careful of two things:
1269          !  1) the value has to be communicated, 2) the value can not increase
1270          !  at subsequent times from the initial value.
1271
1272          IF ( internal_time_loop .EQ. 1 ) THEN
1273             CALL find_p_top ( grid%p_gc , grid%p_top , &
1274                               ids , ide , jds , jde , 1   , num_metgrid_levels , &
1275                               ims , ime , jms , jme , 1   , num_metgrid_levels , &
1276                               its , ite , jts , jte , 1   , num_metgrid_levels )
1277
1278 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
1279             grid%p_top = wrf_dm_max_real ( grid%p_top )
1280 #endif
1281
1282             !  Compare the requested grid%p_top with the value available from the input data.
1283
1284             IF ( p_top_requested .LT. grid%p_top ) THEN
1285                print *,'p_top_requested = ',p_top_requested
1286                print *,'allowable grid%p_top in data   = ',grid%p_top
1287                CALL wrf_error_fatal ( 'p_top_requested < grid%p_top possible from data' )
1288             END IF
1289
1290             !  The grid%p_top valus is the max of what is available from the data and the
1291             !  requested value.  We have already compared <, so grid%p_top is directly set to
1292             !  the value in the namelist.
1293
1294             grid%p_top = p_top_requested
1295
1296             !  For subsequent times, we have to remember what the grid%p_top for the first
1297             !  time was.  Why?  If we have a generalized vert coordinate, the grid%p_top value
1298             !  could fluctuate.
1299
1300             p_top_save = grid%p_top
1301
1302          ELSE
1303             CALL find_p_top ( grid%p_gc , grid%p_top , &
1304                               ids , ide , jds , jde , 1   , num_metgrid_levels , &
1305                               ims , ime , jms , jme , 1   , num_metgrid_levels , &
1306                               its , ite , jts , jte , 1   , num_metgrid_levels )
1307
1308 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
1309             grid%p_top = wrf_dm_max_real ( grid%p_top )
1310 #endif
1311             IF ( grid%p_top .GT. p_top_save ) THEN
1312                print *,'grid%p_top from last time period = ',p_top_save
1313                print *,'grid%p_top from this time period = ',grid%p_top
1314                CALL wrf_error_fatal ( 'grid%p_top > previous value' )
1315             END IF
1316             grid%p_top = p_top_save
1317          ENDIF
1318
1319          !  Get the monthly values interpolated to the current date for the traditional monthly
1320          !  fields of green-ness fraction and background albedo.
1321
1322          CALL monthly_interp_to_date ( grid%greenfrac , current_date , grid%vegfra , &
1323                                        ids , ide , jds , jde , kds , kde , &
1324                                        ims , ime , jms , jme , kms , kme , &
1325                                        its , ite , jts , jte , kts , kte )
1326
1327          CALL monthly_interp_to_date ( grid%albedo12m , current_date , grid%albbck , &
1328                                        ids , ide , jds , jde , kds , kde , &
1329                                        ims , ime , jms , jme , kms , kme , &
1330                                        its , ite , jts , jte , kts , kte )
1331
1332          CALL monthly_interp_to_date ( grid%lai12m , current_date , grid%lai , &
1333                                        ids , ide , jds , jde , kds , kde , &
1334                                        ims , ime , jms , jme , kms , kme , &
1335                                        its , ite , jts , jte , kts , kte )
1336
1337 #if ( WRF_CHEM == 1 )
1338          ! Chose the appropriate LAI veg mask for this date (used in the AFWA dust model)
1339
1340          CALL eightday_selector ( grid%lai_veg_8day , current_date , grid%lai_vegmask , &
1341                                        ids , ide , jds , jde , kds , kde , &
1342                                        ims , ime , jms , jme , kms , kme , &
1343                                        its , ite , jts , jte , kts , kte )
1344 #endif
1345
1346          !  Get the min/max of each i,j for the monthly green-ness fraction.
1347
1348          CALL monthly_min_max ( grid%greenfrac , grid%shdmin , grid%shdmax , &
1349                                 ids , ide , jds , jde , kds , kde , &
1350                                 ims , ime , jms , jme , kms , kme , &
1351                                 its , ite , jts , jte , kts , kte )
1352
1353          CALL monthly_avg ( grid%greenfrac , grid%shdavg , &
1354                                 ids , ide , jds , jde , kds , kde , &
1355                                 ims , ime , jms , jme , kms , kme , &
1356                                 its , ite , jts , jte , kts , kte )
1357
1358          !  The model expects the green-ness and vegetation fraction values to be in percent, not fraction.
1359
1360          DO j = jts, MIN(jte,jde-1)
1361            DO i = its, MIN(ite,ide-1)
1362               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1363               grid%vegfra(i,j) = grid%vegfra(i,j) * 100.
1364               grid%shdmax(i,j) = grid%shdmax(i,j) * 100.
1365               grid%shdmin(i,j) = grid%shdmin(i,j) * 100.
1366               grid%shdavg(i,j) = grid%shdavg(i,j) * 100.
1367               END DO
1368          END DO
1369
1370          !  The model expects the albedo fields as a fraction, not a percent.  Set the
1371          !  water values to 8%.
1372
1373          DO j = jts, MIN(jte,jde-1)
1374             DO i = its, MIN(ite,ide-1)
1375                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1376                grid%albbck(i,j) = grid%albbck(i,j) / 100.
1377                grid%snoalb(i,j) = grid%snoalb(i,j) / 100.
1378                IF ( grid%landmask(i,j) .LT. 0.5 ) THEN
1379                   grid%albbck(i,j) = 0.08
1380                   grid%snoalb(i,j) = 0.08
1381                END IF
1382             END DO
1383          END DO
1384
1385          !  Two ways to get the surface pressure.  1) If we have the low-res input surface
1386          !  pressure and the low-res topography, then we can do a simple hydrostatic
1387          !  relation.  2) Otherwise we compute the surface pressure from the sea-level
1388          !  pressure.
1389          !  Note that on output, grid%psfc is now hi-res.  The low-res surface pressure and
1390          !  elevation are grid%psfc_gc and grid%ht_gc (same as grid%ght_gc(k=1)).
1391
1392          IF      ( ( flag_psfc    .EQ. 1 ) .AND. &
1393                    ( flag_soilhgt .EQ. 1 ) .AND. &
1394                    ( flag_slp     .EQ. 1 ) .AND. &
1395                    ( .NOT. config_flags%sfcp_to_sfcp ) ) THEN
1396             WRITE(a_message,FMT='(A)') 'Using sfcprs3 to compute psfc'
1397             CALL wrf_message ( a_message )
1398             CALL sfcprs3(grid%ght_gc, grid%p_gc, grid%ht, &
1399                          grid%pslv_gc, grid%psfc, &
1400                          ids , ide , jds , jde , 1   , num_metgrid_levels , &
1401                          ims , ime , jms , jme , 1   , num_metgrid_levels , &
1402                          its , ite , jts , jte , 1   , num_metgrid_levels )
1403          ELSE IF ( ( flag_psfc    .EQ. 1 ) .AND. &
1404                    ( flag_soilhgt .EQ. 1 ) .AND. &
1405                    ( config_flags%sfcp_to_sfcp ) ) THEN
1406             WRITE(a_message,FMT='(A)') 'Using sfcprs2 to compute psfc'
1407             CALL wrf_message ( a_message )
1408             CALL sfcprs2(grid%t_gc, grid%qv_gc, grid%ght_gc, grid%psfc_gc, grid%ht, &
1409                          grid%tavgsfc, grid%p_gc, grid%psfc, we_have_tavgsfc, &
1410                          ids , ide , jds , jde , 1   , num_metgrid_levels , &
1411                          ims , ime , jms , jme , 1   , num_metgrid_levels , &
1412                          its , ite , jts , jte , 1   , num_metgrid_levels )
1413          ELSE IF ( flag_slp     .EQ. 1 ) THEN
1414             WRITE(a_message,FMT='(A)') 'Using sfcprs  to compute psfc'
1415             CALL wrf_message ( a_message )
1416             CALL sfcprs (grid%t_gc, grid%qv_gc, grid%ght_gc, grid%pslv_gc, grid%ht, &
1417                          grid%tavgsfc, grid%p_gc, grid%psfc, we_have_tavgsfc, &
1418                          ids , ide , jds , jde , 1   , num_metgrid_levels , &
1419                          ims , ime , jms , jme , 1   , num_metgrid_levels , &
1420                          its , ite , jts , jte , 1   , num_metgrid_levels )
1421          ELSE
1422             WRITE(a_message,FMT='(3(A,I2),A,L1)') 'ERROR in psfc: flag_psfc = ',flag_psfc, &
1423                                                ', flag_soilhgt = ',flag_soilhgt , &
1424                                                ', flag_slp = ',flag_slp , &
1425                                                ', sfcp_to_sfcp = ',config_flags%sfcp_to_sfcp
1426             CALL wrf_message ( a_message )
1427             CALL wrf_error_fatal ( 'not enough info for a p sfc computation' )
1428          END IF
1429
1430          !  If we have no input surface pressure, we'd better stick something in there.
1431
1432          IF ( flag_psfc .NE. 1 ) THEN
1433             DO j = jts, MIN(jte,jde-1)
1434               DO i = its, MIN(ite,ide-1)
1435                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1436                  grid%psfc_gc(i,j) = grid%psfc(i,j)
1437                  grid%p_gc(i,1,j) = grid%psfc(i,j)
1438               END DO
1439             END DO
1440          END IF
1441
1442          !  Integrate the mixing ratio to get the vapor pressure.
1443
1444          CALL integ_moist ( grid%qv_gc , grid%p_gc , grid%pd_gc , grid%t_gc , grid%ght_gc , grid%intq_gc , &
1445                             ids , ide , jds , jde , 1   , num_metgrid_levels , &
1446                             ims , ime , jms , jme , 1   , num_metgrid_levels , &
1447                             its , ite , jts , jte , 1   , num_metgrid_levels )
1448
1449          !  If this is UM data, the same moisture removed from the "theta" level pressure data can
1450          !  be removed from the "rho" level pressures.  This is an approximation.  We'll revisit to
1451          !  see if this is a bad idea.
1452
1453          IF ( flag_ptheta .EQ. 1 ) THEN
1454             DO j = jts, MIN(jte,jde-1)
1455                DO k = num_metgrid_levels-1 , 1 , -1
1456                   DO i = its, MIN(ite,ide-1)
1457                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1458                      ptemp = ((grid%p_gc(i,k,j) - grid%pd_gc(i,k,j)) + (grid%p_gc(i,k+1,j) - grid%pd_gc(i,k+1,j)))/2
1459                      grid%pdrho_gc(i,k,j) = grid%prho_gc(i,k,j) - ptemp
1460                   END DO
1461                END DO
1462             END DO
1463          END IF
1464
1465
1466          !  Compute the difference between the dry, total surface pressure (input) and the
1467          !  dry top pressure (constant).
1468
1469          CALL p_dts ( grid%mu0 , grid%intq_gc , grid%psfc , grid%p_top , &
1470                       ids , ide , jds , jde , 1   , num_metgrid_levels , &
1471                       ims , ime , jms , jme , 1   , num_metgrid_levels , &
1472                       its , ite , jts , jte , 1   , num_metgrid_levels )
1473
1474          !  Compute the dry, hydrostatic surface pressure.
1475
1476          CALL p_dhs ( grid%pdhs , grid%ht , p00 , t00 , a , &
1477                       ids , ide , jds , jde , kds , kde , &
1478                       ims , ime , jms , jme , kms , kme , &
1479                       its , ite , jts , jte , kts , kte )
1480
1481          !  Compute the eta levels if not defined already.
1482
1483          IF ( grid%znw(1) .NE. 1.0 ) THEN
1484            !DJW Check if any of the domains are going to use vertical
1485            !nesting with vert_refine_method=2. If so, set vnest as true.
1486            vnest = .FALSE.
1487            DO id=1,model_config_rec%max_dom
1488              IF (model_config_rec%vert_refine_method(id) .EQ. 2) THEN
1489                vnest = .TRUE.
1490              ENDIF
1491            ENDDO
1492            !DJW If there are eta_levels defined in the namelist and at
1493            !least one domain is using vertical nesting, then we need to read in
1494            !the eta_levels.
1495            IF ((model_config_rec%eta_levels(1) .NE. -1.0) .AND. (vnest)) THEN
1496              !DJW Added code for specifying multiple domains' eta_levels.
1497             !First check to make sure that we've not specified more
1498             !eta_levels than the dimensionality of eta_levels can handle! This
1499              !issue will most likely cause a break sometime before this
1500             !check, however it doesn't hurt to include it. To increase max_eta,
1501             !go to frame/module_driver_constants.F.
1502              CALL wrf_debug (0, "module_initialize_real: using vert_refine_method=2, reading in eta_levels from namelist.input")
1503             ks = 0
1504             DO id=1,grid%id
1505               ks = ks+model_config_rec%e_vert(id)
1506             ENDDO
1507             IF (ks .GT. max_eta) THEN
1508               CALL wrf_error_fatal("too many vertical levels, increase max_eta in frame/module_driver_constants.F")
1509             ENDIF
1510             !Now set the eta_levels to what we specified in the namelist. We've
1511             !packed all the domains' eta_levels into a 'vector' and now we need
1512             !to pull only the section of the vector associated with our domain
1513             !of interest, which is between indicies ks and ke.
1514             IF (grid%id .EQ. 1) THEN
1515               ks = 1
1516               ke = model_config_rec%e_vert(1)
1517             ELSE
1518               id = 1
1519               ks = 1
1520               ke = 0
1521               DO WHILE (grid%id .GT. id)
1522                 id = id+1
1523                 ks = ks+model_config_rec%e_vert(id-1)
1524                 ke = ks+model_config_rec%e_vert(id)-1
1525               ENDDO
1526             ENDIF
1527             eta_levels(1:kde) = model_config_rec%eta_levels(ks:ke)
1528             !Check the value of the first and last eta level for our domain,
1529             !then check that the vector of eta levels is only decreasing
1530             IF (eta_levels(1) .NE. 1.0) THEN
1531                CALL wrf_error_fatal("--- ERROR: the first specified eta_level is not 1.0")
1532             ENDIF
1533             IF (eta_levels(kde) .NE. 0.0) THEN
1534                CALL wrf_error_fatal("--- ERROR: the last specified eta_level is not 0.0")
1535             ENDIF
1536             DO k=2,kde
1537               IF (eta_levels(k) .GT. eta_levels(k-1)) THEN
1538                  CALL wrf_error_fatal("--- ERROR: specified eta_levels are not uniformly decreasing from 1.0 to 0.0")
1539               ENDIF
1540             ENDDO
1541              !DJW End of added code for specifying eta_levels
1542            ELSE !We're not using vertical nesting with eta_levels defined for every domain
1543              !DJW Check if we're doing vertical nesting with integer refinement.
1544              vnest = .FALSE.
1545              DO id=1,model_config_rec%max_dom
1546                IF (model_config_rec%vert_refine_method(id) .EQ. 1) THEN
1547                  vnest = .TRUE.
1548                ENDIF
1549              ENDDO
1550              !DJW If we're doing vertical nesting using integer refinement and
1551              !we've got eta_levels specified in the namelist then make sure they are
1552              !for the parent domain and nothing else.
1553              IF ((vnest) .AND. (model_config_rec%eta_levels(kde+1) .NE. -1.0)) THEN
1554                write(wrf_err_message,'(A)') "--- ERROR: too many eta_levels defined in namelist.input."
1555                CALL wrf_error_fatal( wrf_err_message )
1556              !DJW Check the value of the first and last eta level for our
1557              !domain, then check that the vector of eta levels is only decreasing
1558              ELSEIF ((vnest) .AND. (model_config_rec%eta_levels(1) .NE. -1.0)) THEN
1559                CALL wrf_debug(0, "module_initialize_real: using vert_refine_method=1, reading in eta_levels for d01 from namelist.input")
1560              eta_levels(1:kde) = model_config_rec%eta_levels(1:kde)
1561                IF (eta_levels(1) .NE. 1.0) THEN
1562                  CALL wrf_error_fatal("--- ERROR: the first specified eta_level is not 1.0")
1563                ENDIF
1564                IF (eta_levels(kde) .NE. 0.0) THEN
1565                  CALL wrf_error_fatal("--- ERROR: the last specified eta_level is not 0.0")
1566                ENDIF
1567                DO k=2,kde
1568                  IF (eta_levels(k) .GT. eta_levels(k-1)) THEN
1569                    CALL wrf_error_fatal("--- ERROR: specified eta_levels are not uniformly decreasing from 1.0 to 0.0")
1570                  ENDIF
1571                ENDDO
1572              ELSE
1573                !DJW original code to set eta_levels
1574                eta_levels(1:kde) = model_config_rec%eta_levels(1:kde)
1575              ENDIF
1576            ENDIF
1577
1578             max_dz            = model_config_rec%max_dz
1579             dzbot             = model_config_rec%dzbot
1580             dzstretch_s       = model_config_rec%dzstretch_s
1581             dzstretch_u       = model_config_rec%dzstretch_u
1582             auto_levels_opt  = model_config_rec%auto_levels_opt
1583
1584             CALL compute_eta ( grid%znw , auto_levels_opt, &
1585                                eta_levels , max_eta , max_dz , dzbot , dzstretch_s , dzstretch_u , &
1586                                grid%p_top , g , p00 , cvpm , a , r_d , cp , &
1587                                t00 , p1000mb , t0 , tiso , p_strat , a_strat , &
1588                                ids , ide , jds , jde , kds , kde , &
1589                                ims , ime , jms , jme , kms , kme , &
1590                                its , ite , jts , jte , kts , kte )
1591          END IF
1592
1593          !  For vertical coordinate, compute 1d arrays.
1594
1595          CALL compute_vcoord_1d_coeffs ( grid%ht, grid%etac, grid%znw, &
1596                                          config_flags%hybrid_opt, &
1597                                          r_d, g, p1000mb, &
1598                                          grid%p_top, grid%p00, grid%t00, grid%tlp, &
1599                                          ids, ide, jds, jde, kds, kde, &
1600                                          ims, ime, jms, jme, kms, kme, &
1601                                          its, ite, jts, jte, kts, kte, &
1602                                          grid%znu, &
1603                                          grid%c1f, grid%c2f, grid%c3f, grid%c4f, &
1604                                          grid%c1h, grid%c2h, grid%c3h, grid%c4h )
1605
1606          IF ( config_flags%interp_theta ) THEN
1607
1608             !  The input field is temperature, we want potential temp.
1609
1610             CALL t_to_theta ( grid%t_gc , grid%p_gc , p00 , &
1611                               ids , ide , jds , jde , 1   , num_metgrid_levels , &
1612                               ims , ime , jms , jme , 1   , num_metgrid_levels , &
1613                               its , ite , jts , jte , 1   , num_metgrid_levels )
1614          END IF
1615
1616          IF ( flag_slp .EQ. 1 ) THEN
1617
1618             !  On the eta surfaces, compute the dry pressure = mu eta, stored in
1619             !  grid%pb, since it is a pressure, and we don't need another kms:kme 3d
1620             !  array floating around.  The grid%pb array is re-computed as the base pressure
1621             !  later after the vertical interpolations are complete.
1622
1623             CALL p_dry ( grid%mu0 , grid%znw , grid%p_top , grid%pb , want_full_levels , &
1624                          grid%c3f , grid%c3h , grid%c4f , grid%c4h ,  &
1625                          ids , ide , jds , jde , kds , kde , &
1626                          ims , ime , jms , jme , kms , kme , &
1627                          its , ite , jts , jte , kts , kte )
1628
1629             !  All of the vertical interpolations are done in dry-pressure space.  The
1630             !  input data has had the moisture removed (grid%pd_gc).  The target levels (grid%pb)
1631             !  had the vapor pressure removed from the surface pressure, then they were
1632             !  scaled by the eta levels.
1633
1634             interp_type = 2
1635             lagrange_order = grid%lagrange_order
1636             linear_interp = grid%linear_interp
1637             lowest_lev_from_sfc = .FALSE.
1638             use_levels_below_ground = .TRUE.
1639             use_surface = .TRUE.
1640             zap_close_levels = grid%zap_close_levels
1641             force_sfc_in_vinterp = 0
1642             t_extrap_type = grid%t_extrap_type
1643             extrap_type = 1
1644
1645             !  For the height field, the lowest level pressure is the slp (approximately "dry").  The
1646             !  lowest level of the input height field (to be associated with slp) then is an array
1647             !  of zeros.
1648
1649             DO j = jts, MIN(jte,jde-1)
1650                DO i = its, MIN(ite,ide-1)
1651                   grid%psfc_gc(i,j) = grid%pd_gc(i,1,j)
1652                   grid%pd_gc(i,1,j) = grid%pslv_gc(i,j) - ( grid%p_gc(i,1,j) - grid%pd_gc(i,1,j) )
1653                   grid%ht_gc(i,j) = grid%ght_gc(i,1,j)
1654                   grid%ght_gc(i,1,j) = 0.
1655                END DO
1656             END DO
1657
1658 #ifdef DM_PARALLEL
1659          ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte
1660
1661          !  Stencil for pressure is required for the pressure difference for the max_wind
1662          !  and trop level data.
1663
1664 # include "HALO_EM_VINTERP_UV_1.inc"
1665 #endif
1666
1667             CALL vert_interp ( grid%ght_gc , grid%pd_gc , grid%ph0 , grid%pb , &
1668                                grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1669                                grid%pmaxwnn , grid%ptropnn , &
1670                                flag_hgtmaxw , flag_hgttrop , &
1671                                config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1672                                config_flags%maxw_above_this_level , &
1673                                num_metgrid_levels , 'Z' , &
1674                                interp_type , lagrange_order , extrap_type , &
1675                                lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
1676                                zap_close_levels , force_sfc_in_vinterp , grid%id , &
1677                                ids , ide , jds , jde , kds , kde , &
1678                                ims , ime , jms , jme , kms , kme , &
1679                                its , ite , jts , jte , kts , kte )
1680
1681             !  Put things back to normal.
1682
1683             DO j = jts, MIN(jte,jde-1)
1684                DO i = its, MIN(ite,ide-1)
1685                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1686                   grid%pd_gc(i,1,j) = grid%psfc_gc(i,j)
1687                   grid%ght_gc(i,1,j) = grid%ht_gc(i,j)
1688                END DO
1689             END DO
1690
1691          END IF
1692
1693          !  Now the rest of the variables on half-levels to inteprolate.
1694
1695          CALL p_dry ( grid%mu0 , grid%znw , grid%p_top , grid%pb , want_half_levels , &
1696                       grid%c3f , grid%c3h , grid%c4f , grid%c4h ,  &
1697                       ids , ide , jds , jde , kds , kde , &
1698                       ims , ime , jms , jme , kms , kme , &
1699                       its , ite , jts , jte , kts , kte )
1700
1701          interp_type = grid%interp_type
1702          lagrange_order = grid%lagrange_order
1703          lowest_lev_from_sfc = grid%lowest_lev_from_sfc
1704          use_levels_below_ground = grid%use_levels_below_ground
1705          use_surface = grid%use_surface
1706          zap_close_levels = grid%zap_close_levels
1707          force_sfc_in_vinterp = grid%force_sfc_in_vinterp
1708          t_extrap_type = grid%t_extrap_type
1709          extrap_type = grid%extrap_type
1710
1711 #ifdef DM_PARALLEL
1712          ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte
1713
1714          !  Stencil for pressure is required for the pressure difference for the max_wind
1715          !  and trop level data.
1716
1717 # include "HALO_EM_VINTERP_UV_1.inc"
1718 #endif
1719
1720          !  Interpolate RH, diagnose Qv later when have temp and pressure.  Temporarily
1721          !  store this in the u_1 space, for later diagnosis into Qv and stored into moist.
1722
1723          CALL vert_interp ( grid%rh_gc , grid%pd_gc , grid%u_1 , grid%pb , &
1724                             grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1725                             grid%pmaxwnn , grid%ptropnn , &
1726                             0 , 0 , &
1727                             config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1728                             config_flags%maxw_above_this_level , &
1729                             num_metgrid_levels , 'Q' , &
1730                             interp_type , lagrange_order , extrap_type , &
1731                             lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
1732                             zap_close_levels , force_sfc_in_vinterp , grid%id , &
1733                             ids , ide , jds , jde , kds , kde , &
1734                             ims , ime , jms , jme , kms , kme , &
1735                             its , ite , jts , jte , kts , kte )
1736
1737          ! when specific humidity is available, qv_gc is computed from sh_gc
1738          IF (config_flags%use_sh_qv .and. (flag_sh .eq. 1 .or. flag_qv .eq. 1)) THEN
1739          CALL vert_interp ( grid%qv_gc , grid%pd_gc , moist(:,:,:,P_QV) , grid%pb , &
1740                             grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1741                             grid%pmaxwnn , grid%ptropnn , &
1742                             0 , 0 , &
1743                             config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1744                             config_flags%maxw_above_this_level , &
1745                             num_metgrid_levels , 'Q' , &
1746                             interp_type , lagrange_order , extrap_type , &
1747                             lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
1748                             zap_close_levels , force_sfc_in_vinterp , grid%id , &
1749                             ids , ide , jds , jde , kds , kde , &
1750                             ims , ime , jms , jme , kms , kme , &
1751                             its , ite , jts , jte , kts , kte )
1752          END IF
1753
1754          !  If this is theta being interpolated, AND we have extra levels for temperature,
1755          !  convert those extra levels (trop and max wind) to potential temp.
1756
1757          IF ( ( config_flags%interp_theta ) .AND. ( flag_tmaxw .EQ. 1 ) ) THEN
1758             CALL t_to_theta ( grid%tmaxw , grid%pmaxw , p00 , &
1759                               ids , ide , jds , jde , 1 , 1 , &
1760                               ims , ime , jms , jme , 1 , 1 , &
1761                               its , ite , jts , jte , 1 , 1 )
1762          END IF
1763
1764          IF ( ( config_flags%interp_theta ) .AND. ( flag_ttrop .EQ. 1 ) ) THEN
1765             CALL t_to_theta ( grid%ttrop , grid%ptrop , p00 , &
1766                               ids , ide , jds , jde , 1 , 1 , &
1767                               ims , ime , jms , jme , 1 , 1 , &
1768                               its , ite , jts , jte , 1 , 1 )
1769          END IF
1770
1771          !  Depending on the setting of interp_theta = T/F, t_gc is is either theta Xor
1772          !  temperature, and that means that the t_2 field is also the associated field.
1773          !  It is better to interpolate temperature and potential temperature in LOG(p),
1774          !  regardless of requested default.
1775
1776          interp_type = 2
1777          CALL vert_interp ( grid%t_gc , grid%pd_gc , grid%t_2               , grid%pb , &
1778                             grid%tmaxw , grid%ttrop , grid%pmaxw , grid%ptrop , &
1779                             grid%pmaxwnn , grid%ptropnn , &
1780                             flag_tmaxw , flag_ttrop , &
1781                             config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1782                             config_flags%maxw_above_this_level , &
1783                             num_metgrid_levels , 'T' , &
1784                             interp_type , lagrange_order , t_extrap_type , &
1785                             lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
1786                             zap_close_levels , force_sfc_in_vinterp , grid%id , &
1787                             ids , ide , jds , jde , kds , kde , &
1788                             ims , ime , jms , jme , kms , kme , &
1789                             its , ite , jts , jte , kts , kte )
1790          interp_type = grid%interp_type
1791
1792          !  It is better to interpolate pressure in p regardless of the default options
1793
1794          interp_type = 1
1795          CALL vert_interp ( grid%p_gc , grid%pd_gc , grid%p               , grid%pb , &
1796                             grid%pmaxw , grid%ptrop , grid%pmaxw , grid%ptrop , &
1797                             grid%pmaxwnn , grid%ptropnn , &
1798                             flag_pmaxw , flag_ptrop , &
1799                             config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1800                             config_flags%maxw_above_this_level , &
1801                             num_metgrid_levels , 'T' , &
1802                             interp_type , lagrange_order , t_extrap_type , &
1803                             lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
1804                             zap_close_levels , force_sfc_in_vinterp , grid%id , &
1805                             ids , ide , jds , jde , kds , kde , &
1806                             ims , ime , jms , jme , kms , kme , &
1807                             its , ite , jts , jte , kts , kte )
1808          interp_type = grid%interp_type
1809
1810          !  Do not have full pressure on eta levels, get a first guess at Qv by using
1811          !  dry pressure.  The use of u_1 (rh) and v_1 (temperature) is temporary.
1812          !  We fix the approximation to Qv after the total pressure is available on
1813          !  eta surfaces.
1814
1815          grid%v_1 = grid%t_2
1816
1817          IF ( config_flags%interp_theta ) THEN
1818             CALL theta_to_t ( grid%v_1 , grid%p  , p00 , &
1819                               ids , ide , jds , jde , kds , kde , &
1820                               ims , ime , jms , jme , kms , kme , &
1821                               its , ite , jts , jte , kts , kte )
1822          END IF
1823
1824          ! do not compute qv from RH if flag_sh or flag_qv = 1, or use_sh_qv = F
1825          IF      ( .not.config_flags%use_sh_qv ) THEN
1826          IF      ( config_flags%rh2qv_method .eq. 1 ) THEN
1827             CALL rh_to_mxrat1(grid%u_1, grid%v_1, grid%p , moist(:,:,:,P_QV) ,       &
1828                               config_flags%rh2qv_wrt_liquid ,                        &
1829                               config_flags%qv_max_p_safe ,                           &
1830                               config_flags%qv_max_flag , config_flags%qv_max_value , &
1831                               config_flags%qv_min_p_safe ,                           &
1832                               config_flags%qv_min_flag , config_flags%qv_min_value , &
1833                               ids , ide , jds , jde , kds , kde ,                    &
1834                               ims , ime , jms , jme , kms , kme ,                    &
1835                               its , ite , jts , jte , kts , kte-1 )
1836          ELSE IF ( config_flags%rh2qv_method .eq. 2 ) THEN
1837             CALL rh_to_mxrat2(grid%u_1, grid%v_1, grid%p , moist(:,:,:,P_QV) ,       &
1838                               config_flags%rh2qv_wrt_liquid ,                        &
1839                               config_flags%qv_max_p_safe ,                           &
1840                               config_flags%qv_max_flag , config_flags%qv_max_value , &
1841                               config_flags%qv_min_p_safe ,                           &
1842                               config_flags%qv_min_flag , config_flags%qv_min_value , &
1843                               ids , ide , jds , jde , kds , kde ,                    &
1844                               ims , ime , jms , jme , kms , kme ,                    &
1845                               its , ite , jts , jte , kts , kte-1 )
1846          END IF
1847          END IF
1848
1849          IF ( .NOT. config_flags%interp_theta ) THEN
1850             CALL t_to_theta ( grid%t_2 , grid%p , p00 , &
1851                               ids , ide , jds , jde , kds , kde , &
1852                               ims , ime , jms , jme , kms , kme , &
1853                               its , ite , jts , jte , kts , kte-1 )
1854          END IF
1855
1856          num_3d_m = num_moist
1857          num_3d_s = num_scalar
1858
1859          IF ( flag_qr .EQ. 1 ) THEN
1860             DO im = PARAM_FIRST_SCALAR, num_3d_m
1861                IF ( im .EQ. P_QR ) THEN
1862                   CALL vert_interp ( grid%qr_gc , grid%pd_gc , moist(:,:,:,P_QR) , grid%pb , &
1863                                      grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1864                                      grid%pmaxwnn , grid%ptropnn , &
1865                                      0 , 0 , &
1866                                      config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1867                                      config_flags%maxw_above_this_level , &
1868                                      num_metgrid_levels , 'Q' , &
1869                                      interp_type , linear_interp , extrap_type , &
1870                                      .false. , use_levels_below_ground , use_surface , &
1871                                      zap_close_levels , force_sfc_in_vinterp , grid%id , &
1872                                      ids , ide , jds , jde , kds , kde , &
1873                                      ims , ime , jms , jme , kms , kme , &
1874                                      its , ite , jts , jte , kts , kte )
1875                END IF
1876             END DO
1877          END IF
1878
1879          IF ( ( flag_qc .EQ. 1 ) .OR. ( flag_speccldl .EQ. 1 ) ) THEN
1880             DO im = PARAM_FIRST_SCALAR, num_3d_m
1881                IF ( im .EQ. P_QC ) THEN
1882                   IF ( flag_speccldl .EQ. 1 ) THEN
1883                      DO j = jts, MIN(jte,jde-1)
1884                         DO k = 1 , num_metgrid_levels
1885                            DO i = its, MIN(ite,ide-1)
1886                               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1887                               grid%qc_gc(i,k,j) = grid%cl_gc(i,k,j) /( 1. - grid%cl_gc(i,k,j) )
1888                            END DO
1889                         END DO
1890                      END DO
1891                   END IF
1892                   CALL vert_interp ( grid%qc_gc , grid%pd_gc , moist(:,:,:,P_QC) , grid%pb , &
1893                                      grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1894                                      grid%pmaxwnn , grid%ptropnn , &
1895                                      0 , 0 , &
1896                                      config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1897                                      config_flags%maxw_above_this_level , &
1898                                      num_metgrid_levels , 'Q' , &
1899                                      interp_type , linear_interp , extrap_type , &
1900                                      .false. , use_levels_below_ground , use_surface , &
1901                                      zap_close_levels , force_sfc_in_vinterp , grid%id , &
1902                                      ids , ide , jds , jde , kds , kde , &
1903                                      ims , ime , jms , jme , kms , kme , &
1904                                      its , ite , jts , jte , kts , kte )
1905                END IF
1906             END DO
1907          END IF
1908
1909          IF ( ( flag_qi .EQ. 1 ) .OR. ( flag_speccldf .EQ. 1 ) ) THEN
1910             DO im = PARAM_FIRST_SCALAR, num_3d_m
1911                IF ( im .EQ. P_QI ) THEN
1912                   IF ( flag_speccldf .EQ. 1 ) THEN
1913                      DO j = jts, MIN(jte,jde-1)
1914                         DO k = 1 , num_metgrid_levels
1915                            DO i = its, MIN(ite,ide-1)
1916                               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1917                               grid%qi_gc(i,k,j) = grid%cf_gc(i,k,j) /( 1. - grid%cf_gc(i,k,j) )
1918                            END DO
1919                         END DO
1920                      END DO
1921                   END IF
1922                   CALL vert_interp ( grid%qi_gc , grid%pd_gc , moist(:,:,:,P_QI) , grid%pb , &
1923                                      grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1924                                      grid%pmaxwnn , grid%ptropnn , &
1925                                      0 , 0 , &
1926                                      config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1927                                      config_flags%maxw_above_this_level , &
1928                                      num_metgrid_levels , 'Q' , &
1929                                      interp_type , linear_interp , extrap_type , &
1930                                      .false. , use_levels_below_ground , use_surface , &
1931                                      zap_close_levels , force_sfc_in_vinterp , grid%id , &
1932                                      ids , ide , jds , jde , kds , kde , &
1933                                      ims , ime , jms , jme , kms , kme , &
1934                                      its , ite , jts , jte , kts , kte )
1935                END IF
1936             END DO
1937          END IF
1938
1939          IF ( flag_qs .EQ. 1 ) THEN
1940             DO im = PARAM_FIRST_SCALAR, num_3d_m
1941                IF ( im .EQ. P_QS ) THEN
1942                   CALL vert_interp ( grid%qs_gc , grid%pd_gc , moist(:,:,:,P_QS) , grid%pb , &
1943                                      grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1944                                      grid%pmaxwnn , grid%ptropnn , &
1945                                      0 , 0 , &
1946                                      config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1947                                      config_flags%maxw_above_this_level , &
1948                                      num_metgrid_levels , 'Q' , &
1949                                      interp_type , linear_interp , extrap_type , &
1950                                      .false. , use_levels_below_ground , use_surface , &
1951                                      zap_close_levels , force_sfc_in_vinterp , grid%id , &
1952                                      ids , ide , jds , jde , kds , kde , &
1953                                      ims , ime , jms , jme , kms , kme , &
1954                                      its , ite , jts , jte , kts , kte )
1955                END IF
1956             END DO
1957          END IF
1958
1959          IF ( flag_qg .EQ. 1 ) THEN
1960             DO im = PARAM_FIRST_SCALAR, num_3d_m
1961                IF ( im .EQ. P_QG ) THEN
1962                   CALL vert_interp ( grid%qg_gc , grid%pd_gc , moist(:,:,:,P_QG) , grid%pb , &
1963                                      grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1964                                      grid%pmaxwnn , grid%ptropnn , &
1965                                      0 , 0 , &
1966                                      config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1967                                      config_flags%maxw_above_this_level , &
1968                                      num_metgrid_levels , 'Q' , &
1969                                      interp_type , linear_interp , extrap_type , &
1970                                      .false. , use_levels_below_ground , use_surface , &
1971                                      zap_close_levels , force_sfc_in_vinterp , grid%id , &
1972                                      ids , ide , jds , jde , kds , kde , &
1973                                      ims , ime , jms , jme , kms , kme , &
1974                                      its , ite , jts , jte , kts , kte )
1975                END IF
1976             END DO
1977          END IF
1978
1979          IF ( flag_qh .EQ. 1 ) THEN
1980             DO im = PARAM_FIRST_SCALAR, num_3d_m
1981                IF ( im .EQ. P_QH ) THEN
1982                   CALL vert_interp ( grid%qh_gc , grid%pd_gc , moist(:,:,:,P_QH) , grid%pb , &
1983                                      grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1984                                      grid%pmaxwnn , grid%ptropnn , &
1985                                      0 , 0 , &
1986                                      config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1987                                      config_flags%maxw_above_this_level , &
1988                                      num_metgrid_levels , 'Q' , &
1989                                      interp_type , linear_interp , extrap_type , &
1990                                      .false. , use_levels_below_ground , use_surface , &
1991                                      zap_close_levels , force_sfc_in_vinterp , grid%id , &
1992                                      ids , ide , jds , jde , kds , kde , &
1993                                      ims , ime , jms , jme , kms , kme , &
1994                                      its , ite , jts , jte , kts , kte )
1995                END IF
1996             END DO
1997          END IF
1998
1999          IF ( flag_qni .EQ. 1 ) THEN
2000             DO im = PARAM_FIRST_SCALAR, num_3d_s
2001                IF ( im .EQ. P_QNI ) THEN
2002                   CALL vert_interp ( grid%qni_gc , grid%pd_gc , scalar(:,:,:,P_QNI) , grid%pb , &
2003                                      grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2004                                      grid%pmaxwnn , grid%ptropnn , &
2005                                      0 , 0 , &
2006                                      config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2007                                      config_flags%maxw_above_this_level , &
2008                                      num_metgrid_levels , 'Q' , &
2009                                      interp_type , linear_interp , extrap_type , &
2010                                      .false. , use_levels_below_ground , use_surface , &
2011                                      zap_close_levels , force_sfc_in_vinterp , grid%id , &
2012                                      ids , ide , jds , jde , kds , kde , &
2013                                      ims , ime , jms , jme , kms , kme , &
2014                                      its , ite , jts , jte , kts , kte )
2015                END IF
2016             END DO
2017          END IF
2018
2019          IF ( flag_qnc .EQ. 1 ) THEN
2020             DO im = PARAM_FIRST_SCALAR, num_3d_s
2021                IF ( im .EQ. P_QNC ) THEN
2022                   CALL vert_interp ( grid%qnc_gc , grid%pd_gc , scalar(:,:,:,P_QNC) , grid%pb , &
2023                                      grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2024                                      grid%pmaxwnn , grid%ptropnn , &
2025                                      0 , 0 , &
2026                                      config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2027                                      config_flags%maxw_above_this_level , &
2028                                      num_metgrid_levels , 'Q' , &
2029                                      interp_type , linear_interp , extrap_type , &
2030                                      .false. , use_levels_below_ground , use_surface , &
2031                                      zap_close_levels , force_sfc_in_vinterp , grid%id , &
2032                                      ids , ide , jds , jde , kds , kde , &
2033                                      ims , ime , jms , jme , kms , kme , &
2034                                      its , ite , jts , jte , kts , kte )
2035                END IF
2036             END DO
2037          END IF
2038
2039          IF ( flag_qnr .EQ. 1 ) THEN
2040             DO im = PARAM_FIRST_SCALAR, num_3d_s
2041                IF ( im .EQ. P_QNR ) THEN
2042                   CALL vert_interp ( grid%qnr_gc , grid%pd_gc , scalar(:,:,:,P_QNR) , grid%pb , &
2043                                      grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2044                                      grid%pmaxwnn , grid%ptropnn , &
2045                                      0 , 0 , &
2046                                      config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2047                                      config_flags%maxw_above_this_level , &
2048                                      num_metgrid_levels , 'Q' , &
2049                                      interp_type , linear_interp , extrap_type , &
2050                                      .false. , use_levels_below_ground , use_surface , &
2051                                      zap_close_levels , force_sfc_in_vinterp , grid%id , &
2052                                      ids , ide , jds , jde , kds , kde , &
2053                                      ims , ime , jms , jme , kms , kme , &
2054                                      its , ite , jts , jte , kts , kte )
2055                END IF
2056             END DO
2057          END IF
2058
2059          IF ( flag_qns .EQ. 1 ) THEN
2060             DO im = PARAM_FIRST_SCALAR, num_3d_s
2061                IF ( im .EQ. P_QNS ) THEN
2062                   CALL vert_interp ( grid%qns_gc , grid%pd_gc , scalar(:,:,:,P_QNS) , grid%pb , &
2063                                      grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2064                                      grid%pmaxwnn , grid%ptropnn , &
2065                                      0 , 0 , &
2066                                      config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2067                                      config_flags%maxw_above_this_level , &
2068                                      num_metgrid_levels , 'Q' , &
2069                                      interp_type , linear_interp , extrap_type , &
2070                                      .false. , use_levels_below_ground , use_surface , &
2071                                      zap_close_levels , force_sfc_in_vinterp , grid%id , &
2072                                      ids , ide , jds , jde , kds , kde , &
2073                                      ims , ime , jms , jme , kms , kme , &
2074                                      its , ite , jts , jte , kts , kte )
2075                END IF
2076             END DO
2077          END IF
2078
2079          IF ( flag_qng .EQ. 1 ) THEN
2080             DO im = PARAM_FIRST_SCALAR, num_3d_s
2081                IF ( im .EQ. P_QNG ) THEN
2082                   CALL vert_interp ( grid%qng_gc , grid%pd_gc , scalar(:,:,:,P_QNG) , grid%pb , &
2083                                      grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2084                                      grid%pmaxwnn , grid%ptropnn , &
2085                                      0 , 0 , &
2086                                      config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2087                                      config_flags%maxw_above_this_level , &
2088                                      num_metgrid_levels , 'Q' , &
2089                                      interp_type , linear_interp , extrap_type , &
2090                                      .false. , use_levels_below_ground , use_surface , &
2091                                      zap_close_levels , force_sfc_in_vinterp , grid%id , &
2092                                      ids , ide , jds , jde , kds , kde , &
2093                                      ims , ime , jms , jme , kms , kme , &
2094                                      its , ite , jts , jte , kts , kte )
2095                END IF
2096             END DO
2097          END IF
2098
2099          IF ( flag_qnh .EQ. 1 ) THEN
2100             DO im = PARAM_FIRST_SCALAR, num_3d_s
2101                IF ( im .EQ. P_QNH ) THEN
2102                   CALL vert_interp ( grid%qnh_gc , grid%pd_gc , scalar(:,:,:,P_QNH) , grid%pb , &
2103                                      grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2104                                      grid%pmaxwnn , grid%ptropnn , &
2105                                      0 , 0 , &
2106                                      config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2107                                      config_flags%maxw_above_this_level , &
2108                                      num_metgrid_levels , 'Q' , &
2109                                      interp_type , linear_interp , extrap_type , &
2110                                      .false. , use_levels_below_ground , use_surface , &
2111                                      zap_close_levels , force_sfc_in_vinterp , grid%id , &
2112                                      ids , ide , jds , jde , kds , kde , &
2113                                      ims , ime , jms , jme , kms , kme , &
2114                                      its , ite , jts , jte , kts , kte )
2115                END IF
2116             END DO
2117          END IF
2118
2119 !=========================================================================================
2120 !    START OF OPTIONAL 3D DATA, USUALLY AEROSOLS
2121 !=========================================================================================
2122
2123 #if ( WRF_CHEM == 1 )
2124          !  Do we have the old data that came in on the same vertical levels as the other
2125          !  met variables? If so, we can skip all of this interpolation, as the pressure field
2126          !  is allocated, but all zeros.
2127
2128          IF ( config_flags%gca_input_opt .EQ. 1 ) THEN
2129          IF ( ( config_flags%num_gca_levels .GT. 0 ) .AND. &
2130               ( ABS(grid %p_gca(its,config_flags%num_gca_levels/2,jts)) .GT. 1 ) ) THEN
2131
2132             !  Insert source code here to vertically interpolate an extra set of 3d arrays
2133             !  that could be on a different vertical structure than the input atmospheric
2134             !  data.  Mostly, this is expected to be for monthly data (such as background
2135             !  aerosol information).
2136
2137             ! OPTIONAL DATA #1: GCA - Go Cart Aerosols: OH, H2O2, NO3
2138             !       Pressure name: p_gca
2139             !       Number of vertical levels: num_gca_levels
2140             !       Variable names (assumed to end with _jan, _feb, _mar, ..., _nov, _dec): oh, h2o2, no3
2141             !       Option to interpolate data: gca_input_opt = 1
2142             !       Not stored in scalar arrays.
2143
2144             IF ( config_flags%gca_input_opt .EQ. 1 ) THEN
2145
2146                CALL wrf_debug ( 0 , 'Using monthly GOcart Aerosol input: OH, H2O2, NO3 from metgrid input file' )
2147
2148                !  There are three fields - they are 3d, so no easy way to loop over them.
2149                !  OH - Hydroxyl
2150                !  H2O2 - Hydrogen Peroxide
2151                !  NO3 - Nitrate
2152
2153                DO k = 1, config_flags%num_gca_levels
2154                   WRITE(a_message,*) '  transferring each K-level ', k, ' to   OH, sample Jan data, ', grid %  oh_gca_jan(its,k,jts)
2155                   CALL wrf_debug ( 1 , a_message)
2156                   DO j = jts, MIN(jte,jde-1)
2157                      DO i = its, MIN(ite,ide-1)
2158                         grid%qntemp(i, 1, j) = grid %  oh_gca_jan(i,k,j)
2159                         grid%qntemp(i, 2, j) = grid %  oh_gca_feb(i,k,j)
2160                         grid%qntemp(i, 3, j) = grid %  oh_gca_mar(i,k,j)
2161                         grid%qntemp(i, 4, j) = grid %  oh_gca_apr(i,k,j)
2162                         grid%qntemp(i, 5, j) = grid %  oh_gca_may(i,k,j)
2163                         grid%qntemp(i, 6, j) = grid %  oh_gca_jun(i,k,j)
2164                         grid%qntemp(i, 7, j) = grid %  oh_gca_jul(i,k,j)
2165                         grid%qntemp(i, 8, j) = grid %  oh_gca_aug(i,k,j)
2166                         grid%qntemp(i, 9, j) = grid %  oh_gca_sep(i,k,j)
2167                         grid%qntemp(i,10, j) = grid %  oh_gca_oct(i,k,j)
2168                         grid%qntemp(i,11, j) = grid %  oh_gca_nov(i,k,j)
2169                         grid%qntemp(i,12, j) = grid %  oh_gca_dec(i,k,j)
2170                      END DO
2171                   END DO
2172                   IF ( k .EQ. 1 ) THEN
2173                      WRITE(a_message,*) ' GOcart Aerosols   OH (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts)
2174                      CALL wrf_debug ( 1 , a_message)
2175                   END IF
2176                   CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2177                                                 ids , ide , jds , jde , kds , kde , &
2178                                                 ims , ime , jms , jme , kms , kme , &
2179                                                 its , ite , jts , jte , kts , kte )
2180                   IF ( k .eq. 1 ) THEN
2181                      write(a_message,*) ' GOcart Aerosols   OH (now) ', grid%qntemp2(its,jts)
2182                      CALL wrf_debug ( 1 , a_message)
2183                   END IF
2184                   DO j = jts, MIN(jte,jde-1)
2185                      DO i = its, MIN(ite,ide-1)
2186                         grid %  oh_gca_now(i,k,j) = grid%qntemp2(i,j)
2187                      END DO
2188                   END DO
2189                END DO
2190
2191                CALL vert_interp ( grid %  oh_gca_now , grid%p_gca , grid%backg_oh   , grid%pb , &
2192                                   grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2193                                   grid%pmaxwnn , grid%ptropnn , &
2194                                   0 , 0 , &
2195                                   config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2196                                   config_flags%maxw_above_this_level , &
2197                                   config_flags%num_gca_levels , 'Q' , &
2198                                   interp_type , linear_interp , extrap_type , &
2199                                   .false. , use_levels_below_ground , use_surface , &
2200                                   zap_close_levels , force_sfc_in_vinterp , grid%id , &
2201                                   ids , ide , jds , jde , kds , kde , &
2202                                   ims , ime , jms , jme , kms , kme , &
2203                                   its , ite , jts , jte , kts , kte )
2204
2205                DO k = 1, config_flags%num_gca_levels
2206                   WRITE(a_message,*) '  transferring each K-level ', k, ' to H2O2, sample Jan data, ', grid %h2o2_gca_jan(its,k,jts)
2207                   CALL wrf_debug ( 1 , a_message)
2208                   DO j = jts, MIN(jte,jde-1)
2209                      DO i = its, MIN(ite,ide-1)
2210                         grid%qntemp(i, 1, j) = grid %h2o2_gca_jan(i,k,j)
2211                         grid%qntemp(i, 2, j) = grid %h2o2_gca_feb(i,k,j)
2212                         grid%qntemp(i, 3, j) = grid %h2o2_gca_mar(i,k,j)
2213                         grid%qntemp(i, 4, j) = grid %h2o2_gca_apr(i,k,j)
2214                         grid%qntemp(i, 5, j) = grid %h2o2_gca_may(i,k,j)
2215                         grid%qntemp(i, 6, j) = grid %h2o2_gca_jun(i,k,j)
2216                         grid%qntemp(i, 7, j) = grid %h2o2_gca_jul(i,k,j)
2217                         grid%qntemp(i, 8, j) = grid %h2o2_gca_aug(i,k,j)
2218                         grid%qntemp(i, 9, j) = grid %h2o2_gca_sep(i,k,j)
2219                         grid%qntemp(i,10, j) = grid %h2o2_gca_oct(i,k,j)
2220                         grid%qntemp(i,11, j) = grid %h2o2_gca_nov(i,k,j)
2221                         grid%qntemp(i,12, j) = grid %h2o2_gca_dec(i,k,j)
2222                      END DO
2223                   END DO
2224                   IF ( k .EQ. 1 ) THEN
2225                      WRITE(a_message,*) ' GOcart Aerosols H2O2 (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts)
2226                      CALL wrf_debug ( 1 , a_message)
2227                   END IF
2228                   CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2229                                                 ids , ide , jds , jde , kds , kde , &
2230                                                 ims , ime , jms , jme , kms , kme , &
2231                                                 its , ite , jts , jte , kts , kte )
2232                   IF ( k .eq. 1 ) THEN
2233                      write(a_message,*) ' GOcart Aerosols H2O2 (now) ', grid%qntemp2(its,jts)
2234                      CALL wrf_debug ( 1 , a_message)
2235                   END IF
2236                   DO j = jts, MIN(jte,jde-1)
2237                      DO i = its, MIN(ite,ide-1)
2238                         grid %h2o2_gca_now(i,k,j) = grid%qntemp2(i,j)
2239                      END DO
2240                   END DO
2241                END DO
2242
2243                CALL vert_interp ( grid %h2o2_gca_now , grid%p_gca , grid%backg_h2o2 , grid%pb , &
2244                                   grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2245                                   grid%pmaxwnn , grid%ptropnn , &
2246                                   0 , 0 , &
2247                                   config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2248                                   config_flags%maxw_above_this_level , &
2249                                   config_flags%num_gca_levels , 'Q' , &
2250                                   interp_type , linear_interp , extrap_type , &
2251                                   .false. , use_levels_below_ground , use_surface , &
2252                                   zap_close_levels , force_sfc_in_vinterp , grid%id , &
2253                                   ids , ide , jds , jde , kds , kde , &
2254                                   ims , ime , jms , jme , kms , kme , &
2255                                   its , ite , jts , jte , kts , kte )
2256
2257                DO k = 1, config_flags%num_gca_levels
2258                   WRITE(a_message,*) '  transferring each K-level ', k, ' to  NO3, sample Jan data, ', grid % no3_gca_jan(its,k,jts)
2259                   CALL wrf_debug ( 1 , a_message)
2260                   DO j = jts, MIN(jte,jde-1)
2261                      DO i = its, MIN(ite,ide-1)
2262                         grid%qntemp(i, 1, j) = grid % no3_gca_jan(i,k,j)
2263                         grid%qntemp(i, 2, j) = grid % no3_gca_feb(i,k,j)
2264                         grid%qntemp(i, 3, j) = grid % no3_gca_mar(i,k,j)
2265                         grid%qntemp(i, 4, j) = grid % no3_gca_apr(i,k,j)
2266                         grid%qntemp(i, 5, j) = grid % no3_gca_may(i,k,j)
2267                         grid%qntemp(i, 6, j) = grid % no3_gca_jun(i,k,j)
2268                         grid%qntemp(i, 7, j) = grid % no3_gca_jul(i,k,j)
2269                         grid%qntemp(i, 8, j) = grid % no3_gca_aug(i,k,j)
2270                         grid%qntemp(i, 9, j) = grid % no3_gca_sep(i,k,j)
2271                         grid%qntemp(i,10, j) = grid % no3_gca_oct(i,k,j)
2272                         grid%qntemp(i,11, j) = grid % no3_gca_nov(i,k,j)
2273                         grid%qntemp(i,12, j) = grid % no3_gca_dec(i,k,j)
2274                      END DO
2275                   END DO
2276                   IF ( k .EQ. 1 ) THEN
2277                      WRITE(a_message,*) ' GOcart Aerosols  NO3 (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts)
2278                      CALL wrf_debug ( 1 , a_message)
2279                   END IF
2280                   CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2281                                                 ids , ide , jds , jde , kds , kde , &
2282                                                 ims , ime , jms , jme , kms , kme , &
2283                                                 its , ite , jts , jte , kts , kte )
2284                   IF ( k .eq. 1 ) THEN
2285                      write(a_message,*) ' GOcart Aerosols  NO3 (now) ', grid%qntemp2(its,jts)
2286                      CALL wrf_debug ( 1 , a_message)
2287                   END IF
2288                   DO j = jts, MIN(jte,jde-1)
2289                      DO i = its, MIN(ite,ide-1)
2290                         grid % no3_gca_now(i,k,j) = grid%qntemp2(i,j)
2291                      END DO
2292                   END DO
2293                END DO
2294
2295                CALL vert_interp ( grid % no3_gca_now , grid%p_gca , grid%backg_no3 , grid%pb , &
2296                                   grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2297                                   grid%pmaxwnn , grid%ptropnn , &
2298                                   0 , 0 , &
2299                                   config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2300                                   config_flags%maxw_above_this_level , &
2301                                   config_flags%num_gca_levels , 'Q' , &
2302                                   interp_type , linear_interp , extrap_type , &
2303                                   .false. , use_levels_below_ground , use_surface , &
2304                                   zap_close_levels , force_sfc_in_vinterp , grid%id , &
2305                                   ids , ide , jds , jde , kds , kde , &
2306                                   ims , ime , jms , jme , kms , kme , &
2307                                   its , ite , jts , jte , kts , kte )
2308             END IF
2309             END IF
2310          END IF
2311 #endif
2312
2313             ! OPTIONAL DATA #2: Thompson Water-Friendly Ice-Friendly Aerosols
2314             !       Pressure name (assumed to end with _jan, _feb, _mar, ..., _nov, _dec): p_wif
2315             !       Number of vertical levels: num_wif_levels
2316             !       Variable names (assumed to end with _jan, _feb, _mar, ..., _nov, _dec): w_wif, i_wif
2317             !       Option to interpolate data: wif_input_opt = 1 (water and ice friendly aerosols)
2318             !                                                 = 2 (water and ice friendly + black carbon aerosols)
2319             !       Stored in scalar arrays, tested and assumed to be upside down.
2320             !  There are two data fields plus pressure - they are 3d, so no easy way to loop over them.
2321             !  QNWFA - Number concentration water-friendly aerosols
2322             !  QNIFA - Number concentration ice-friendly aerosols
2323             !  QNBCA - Number concentration black carbon aerosols
2324
2325             aer_init_opt = config_flags%aer_init_opt
2326
2327             if_thompsonaero_3d: IF (config_flags%mp_physics .EQ. THOMPSONAERO .AND. &
2328                 config_flags%wif_input_opt .GT. 0) THEN
2329
2330             select_aer_init_opt_3d: select case (aer_init_opt)
2331
2332                case (0)  ! Initialize to zero
2333
2334                   CALL wrf_debug (0 , 'COMMENT: QNWFA and QNIFA will be initialized to zero values')
2335                   DO im = PARAM_FIRST_SCALAR, num_3d_s
2336                      IF ( im .EQ. P_QNWFA .or. im .EQ. P_QNIFA) THEN
2337                         DO j = jts, MIN(jte,jde-1)
2338                            DO k = kts, kte
2339                               DO i = its, MIN(ite,ide-1)
2340                                  scalar(i,k,j,im) = 0.0
2341                               END DO
2342                            END DO
2343                         END DO
2344                      END IF
2345                   END DO
2346
2347                case (1)  ! Monthly climatology (GOCART, etc.)
2348
2349                   CALL wrf_debug (0 , 'COMMENT: Using monthly climatology aerosols')
2350
2351                   !  First, get the pressure temporally interpolated to the correct date/time since
2352                   !  this is a hybrid coordinate (not isobaric), and the pressure changes by month.
2353                   !  NOTE: The input pressure is not vertically interpolated, but the other two input
2354                   !  fields (QNWFA, QNIFA) are interpolated to the WRF eta coordinate.
2355
2356                   do_pres_cl: if (flag_qnwfa_cl .EQ. 1 .and. flag_qnifa_cl .EQ. 1) then
2357                      if (config_flags%num_wif_levels .EQ. num_wif_levels_default) then
2358                         IF ( grid%p_wif_jan(its,config_flags%num_wif_levels/2-1,jts) - &
2359                            grid%p_wif_jan(its,config_flags%num_wif_levels/2+1,jts) .LT. 0 ) THEN
2360                            wif_upside_down = .TRUE.
2361                         END IF
2362
2363                         DO k = 1, config_flags%num_wif_levels
2364                            DO j = jts, MIN(jte,jde-1)
2365                               DO i = its, MIN(ite,ide-1)
2366                                  grid%qntemp(i, 1, j) = grid %p_wif_jan(i,k,j)
2367                                  grid%qntemp(i, 2, j) = grid %p_wif_feb(i,k,j)
2368                                  grid%qntemp(i, 3, j) = grid %p_wif_mar(i,k,j)
2369                                  grid%qntemp(i, 4, j) = grid %p_wif_apr(i,k,j)
2370                                  grid%qntemp(i, 5, j) = grid %p_wif_may(i,k,j)
2371                                  grid%qntemp(i, 6, j) = grid %p_wif_jun(i,k,j)
2372                                  grid%qntemp(i, 7, j) = grid %p_wif_jul(i,k,j)
2373                                  grid%qntemp(i, 8, j) = grid %p_wif_aug(i,k,j)
2374                                  grid%qntemp(i, 9, j) = grid %p_wif_sep(i,k,j)
2375                                  grid%qntemp(i,10, j) = grid %p_wif_oct(i,k,j)
2376                                  grid%qntemp(i,11, j) = grid %p_wif_nov(i,k,j)
2377                                  grid%qntemp(i,12, j) = grid %p_wif_dec(i,k,j)
2378                               END DO
2379                            END DO
2380                            CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2381                                                          ids , ide , jds , jde , kds , kde , &
2382                                                          ims , ime , jms , jme , kms , kme , &
2383                                                          its , ite , jts , jte , kts , kte )
2384                            IF      (       wif_upside_down ) THEN
2385                               DO j = jts, MIN(jte,jde-1)
2386                                  DO i = its, MIN(ite,ide-1)
2387                                     grid %p_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j)
2388                                  END DO
2389                               END DO
2390                            ELSE IF ( .NOT. wif_upside_down ) THEN
2391                               DO j = jts, MIN(jte,jde-1)
2392                                  DO i = its, MIN(ite,ide-1)
2393                                     grid %p_wif_now(i,                              k,j) = grid%qntemp2(i,j)
2394                                  END DO
2395                               END DO
2396                            END IF
2397                         END DO
2398                      else
2399                         CALL wrf_error_fatal ('mp_physics=28 and use_aero_icbc=.true. but wrong num_wif_levels, please set =30')
2400                      end if
2401                   else
2402                      CALL wrf_error_fatal ('mp_physics=28 and use_aero_icbc=.true. but aerosol climatology field(s) missing' )
2403                   end if do_pres_cl
2404
2405                     ! Water-friendly aerosol
2406                   do_qnwfa_cl: if (flag_qnwfa_cl .EQ. 1) then
2407                      DO k = 1, config_flags%num_wif_levels
2408                         DO j = jts, MIN(jte,jde-1)
2409                            DO i = its, MIN(ite,ide-1)
2410                               grid%qntemp(i, 1, j) = grid %w_wif_jan(i,k,j)
2411                               grid%qntemp(i, 2, j) = grid %w_wif_feb(i,k,j)
2412                               grid%qntemp(i, 3, j) = grid %w_wif_mar(i,k,j)
2413                               grid%qntemp(i, 4, j) = grid %w_wif_apr(i,k,j)
2414                               grid%qntemp(i, 5, j) = grid %w_wif_may(i,k,j)
2415                               grid%qntemp(i, 6, j) = grid %w_wif_jun(i,k,j)
2416                               grid%qntemp(i, 7, j) = grid %w_wif_jul(i,k,j)
2417                               grid%qntemp(i, 8, j) = grid %w_wif_aug(i,k,j)
2418                               grid%qntemp(i, 9, j) = grid %w_wif_sep(i,k,j)
2419                               grid%qntemp(i,10, j) = grid %w_wif_oct(i,k,j)
2420                               grid%qntemp(i,11, j) = grid %w_wif_nov(i,k,j)
2421                               grid%qntemp(i,12, j) = grid %w_wif_dec(i,k,j)
2422                            END DO
2423                         END DO
2424                         CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2425                                                       ids , ide , jds , jde , kds , kde , &
2426                                                       ims , ime , jms , jme , kms , kme , &
2427                                                       its , ite , jts , jte , kts , kte )
2428                         IF      (       wif_upside_down ) THEN
2429                            DO j = jts, MIN(jte,jde-1)
2430                               DO i = its, MIN(ite,ide-1)
2431                                  grid %w_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j)
2432                               END DO
2433                            END DO
2434                         ELSE IF ( .NOT. wif_upside_down ) THEN
2435                            DO j = jts, MIN(jte,jde-1)
2436                               DO i = its, MIN(ite,ide-1)
2437                                  grid %w_wif_now(i,                              k,j) = grid%qntemp2(i,j)
2438                               END DO
2439                            END DO
2440                         END IF
2441                      END DO
2442
2443                      CALL wrf_debug (0 , 'Vertically-interpolating QNWFA climatology from WPS data to fill scalar')
2444                      CALL vert_interp ( grid %w_wif_now , grid%p_wif_now , scalar(:,:,:,P_qnwfa) , grid%pb , &
2445                                         grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2446                                         grid%pmaxwnn , grid%ptropnn , &
2447                                         0 , 0 , &
2448                                         config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2449                                         config_flags%maxw_above_this_level , &
2450                                         config_flags%num_wif_levels , 'Q' , &
2451                                         interp_type , linear_interp , extrap_type , &
2452                                         .false. , use_levels_below_ground , use_surface , &
2453                                         zap_close_levels , force_sfc_in_vinterp , grid%id , &
2454                                         ids , ide , jds , jde , kds , kde , &
2455                                         ims , ime , jms , jme , kms , kme , &
2456                                         its , ite , jts , jte , kts , kte )
2457                   else
2458                      CALL wrf_error_fatal ('mp_physics=28 but there is not QNWFA aerosol information from climatology' )
2459                   end if do_qnwfa_cl
2460
2461                     ! Ice-friendly aerosol
2462                   do_qnifa_cl: if (flag_qnifa_cl .EQ. 1) then
2463                      DO k = 1, config_flags%num_wif_levels
2464                         WRITE(a_message,*) '  transferring each K-level ', k, ' to QNIFA, sample Jan data, ', grid %i_wif_jan(its,k,jts)
2465                         CALL wrf_debug ( 1 , a_message)
2466                         DO j = jts, MIN(jte,jde-1)
2467                            DO i = its, MIN(ite,ide-1)
2468                               grid%qntemp(i, 1, j) = grid %i_wif_jan(i,k,j)
2469                               grid%qntemp(i, 2, j) = grid %i_wif_feb(i,k,j)
2470                               grid%qntemp(i, 3, j) = grid %i_wif_mar(i,k,j)
2471                               grid%qntemp(i, 4, j) = grid %i_wif_apr(i,k,j)
2472                               grid%qntemp(i, 5, j) = grid %i_wif_may(i,k,j)
2473                               grid%qntemp(i, 6, j) = grid %i_wif_jun(i,k,j)
2474                               grid%qntemp(i, 7, j) = grid %i_wif_jul(i,k,j)
2475                               grid%qntemp(i, 8, j) = grid %i_wif_aug(i,k,j)
2476                               grid%qntemp(i, 9, j) = grid %i_wif_sep(i,k,j)
2477                               grid%qntemp(i,10, j) = grid %i_wif_oct(i,k,j)
2478                               grid%qntemp(i,11, j) = grid %i_wif_nov(i,k,j)
2479                               grid%qntemp(i,12, j) = grid %i_wif_dec(i,k,j)
2480                            END DO
2481                         END DO
2482                         IF ( k .EQ. 1 ) THEN
2483                            WRITE(a_message,*) ' QNIFA (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts)
2484                            CALL wrf_debug ( 1 , a_message)
2485                         END IF
2486                         CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2487                                                       ids , ide , jds , jde , kds , kde , &
2488                                                       ims , ime , jms , jme , kms , kme , &
2489                                                       its , ite , jts , jte , kts , kte )
2490                         IF ( k .eq. 1 ) THEN
2491                            write(a_message,*) ' QNIFA (now) ', grid%qntemp2(its,jts)
2492                            CALL wrf_debug ( 1 , a_message)
2493                         END IF
2494                         IF      (       wif_upside_down ) THEN
2495                            DO j = jts, MIN(jte,jde-1)
2496                               DO i = its, MIN(ite,ide-1)
2497                                  grid %i_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j)
2498                               END DO
2499                            END DO
2500                         ELSE IF ( .NOT. wif_upside_down ) THEN
2501                            DO j = jts, MIN(jte,jde-1)
2502                               DO i = its, MIN(ite,ide-1)
2503                                  grid %i_wif_now(i,                              k,j) = grid%qntemp2(i,j)
2504                               END DO
2505                            END DO
2506                         END IF
2507                      END DO
2508
2509                      CALL wrf_debug (0 , 'Vertically-interpolating QNIFA climatology from WPS data to fill scalar')
2510                      CALL vert_interp ( grid %i_wif_now , grid%p_wif_now , scalar(:,:,:,P_qnifa) , grid%pb , &
2511                                         grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2512                                         grid%pmaxwnn , grid%ptropnn , &
2513                                         0 , 0 , &
2514                                         config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2515                                         config_flags%maxw_above_this_level , &
2516                                         config_flags%num_wif_levels , 'Q' , &
2517                                         interp_type , linear_interp , extrap_type , &
2518                                         .false. , use_levels_below_ground , use_surface , &
2519                                         zap_close_levels , force_sfc_in_vinterp , grid%id , &
2520                                         ids , ide , jds , jde , kds , kde , &
2521                                         ims , ime , jms , jme , kms , kme , &
2522                                         its , ite , jts , jte , kts , kte )
2523                   else
2524                      CALL wrf_error_fatal ('mp_physics=28 but there is not QNIFA aerosol information from climatology' )
2525                   end if do_qnifa_cl
2526
2527                     ! Black carbon aerosol
2528                   if (config_flags%wif_input_opt .EQ. 2) then
2529                      do_qnbca_cl: if (flag_qnbca_cl .EQ. 1) then
2530                         DO k = 1, config_flags%num_wif_levels
2531                            WRITE(a_message,*) '  transferring each K-level ', k, ' to QNBCA, sample Jan data, ', grid %b_wif_jan(its,k,jts)
2532                            CALL wrf_debug ( 1 , a_message)
2533                            DO j = jts, MIN(jte,jde-1)
2534                               DO i = its, MIN(ite,ide-1)
2535                                  grid%qntemp(i, 1, j) = grid %b_wif_jan(i,k,j)
2536                                  grid%qntemp(i, 2, j) = grid %b_wif_feb(i,k,j)
2537                                  grid%qntemp(i, 3, j) = grid %b_wif_mar(i,k,j)
2538                                  grid%qntemp(i, 4, j) = grid %b_wif_apr(i,k,j)
2539                                  grid%qntemp(i, 5, j) = grid %b_wif_may(i,k,j)
2540                                  grid%qntemp(i, 6, j) = grid %b_wif_jun(i,k,j)
2541                                  grid%qntemp(i, 7, j) = grid %b_wif_jul(i,k,j)
2542                                  grid%qntemp(i, 8, j) = grid %b_wif_aug(i,k,j)
2543                                  grid%qntemp(i, 9, j) = grid %b_wif_sep(i,k,j)
2544                                  grid%qntemp(i,10, j) = grid %b_wif_oct(i,k,j)
2545                                  grid%qntemp(i,11, j) = grid %b_wif_nov(i,k,j)
2546                                  grid%qntemp(i,12, j) = grid %b_wif_dec(i,k,j)
2547                               END DO
2548                            END DO
2549                            IF ( k .EQ. 1 ) THEN
2550                               WRITE(a_message,*) ' QNBCA (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts)
2551                               CALL wrf_debug ( 1 , a_message)
2552                            END IF
2553                            CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2554                                                          ids , ide , jds , jde , kds , kde , &
2555                                                          ims , ime , jms , jme , kms , kme , &
2556                                                          its , ite , jts , jte , kts , kte )
2557                            IF ( k .eq. 1 ) THEN
2558                               write(a_message,*) ' QNBCA (now) ', grid%qntemp2(its,jts)
2559                               CALL wrf_debug ( 1 , a_message)
2560                            END IF
2561                            IF      (       wif_upside_down ) THEN
2562                               DO j = jts, MIN(jte,jde-1)
2563                                  DO i = its, MIN(ite,ide-1)
2564                                     grid %b_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j)
2565                                  END DO
2566                               END DO
2567                            ELSE IF ( .NOT. wif_upside_down ) THEN
2568                               DO j = jts, MIN(jte,jde-1)
2569                                  DO i = its, MIN(ite,ide-1)
2570                                     grid %b_wif_now(i,                              k,j) = grid%qntemp2(i,j)
2571                                  END DO
2572                               END DO
2573                            END IF
2574                         END DO
2575
2576                         CALL wrf_debug (0 , 'Vertically-interpolating QNBCA climatology from WPS data to fill scalar')
2577                         CALL vert_interp ( grid %b_wif_now , grid%p_wif_now , scalar(:,:,:,P_qnbca) , grid%pb , &
2578                                            grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2579                                            grid%pmaxwnn , grid%ptropnn , &
2580                                            0 , 0 , &
2581                                            config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2582                                            config_flags%maxw_above_this_level , &
2583                                            config_flags%num_wif_levels , 'Q' , &
2584                                            interp_type , linear_interp , extrap_type , &
2585                                            .false. , use_levels_below_ground , use_surface , &
2586                                            zap_close_levels , force_sfc_in_vinterp , grid%id , &
2587                                            ids , ide , jds , jde , kds , kde , &
2588                                            ims , ime , jms , jme , kms , kme , &
2589                                            its , ite , jts , jte , kts , kte )
2590                      else
2591                         CALL wrf_error_fatal ('mp_physics=28 and wif_input_opt=2 but there is not QNBCA aerosol information from climatology' )
2592                      end if do_qnbca_cl
2593                   end if
2594
2595                case (2)  ! First guess aerosol (GEOS-5, etc.)
2596
2597                   CALL wrf_debug (0 , 'COMMENT: Using first guess aerosols')
2598
2599                     ! Water-friendly aerosol
2600                   do_qnwfa: if (flag_qnwfa .EQ. 1) then
2601                      if (flag_p_wif .EQ. 1 ) then  ! Interpolate according to native pressure field from aerosol forcing model
2602                         CALL wrf_debug (0 , 'Vertically-interpolating QNWFA first guess from WPS data to fill scalar using native pressure field')
2603                         CALL wrf_debug (0 , 'COMMENT: BE SURE num_wif_levels IN NAMELIST EQUALS num_wif_levels IN MET_EM FILES!')
2604                         CALL vert_interp ( grid%qnwfa_gc , grid%p_wif_gc , scalar(:,:,:,P_QNWFA) , grid%pb , &
2605                                            grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2606                                            grid%pmaxwnn , grid%ptropnn , &
2607                                            0 , 0 , &
2608                                            config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2609                                            config_flags%maxw_above_this_level , &
2610                                            config_flags%num_wif_levels , 'Q' , &
2611                                            interp_type , linear_interp , extrap_type , &
2612                                            .false. , use_levels_below_ground , use_surface , &
2613                                            zap_close_levels , force_sfc_in_vinterp , grid%id , &
2614                                            ids , ide , jds , jde , kds , kde , &
2615                                            ims , ime , jms , jme , kms , kme , &
2616                                            its , ite , jts , jte , kts , kte )
2617                      else  ! Interpolate according to metgrid pressure field
2618                         if (config_flags%num_wif_levels .EQ. num_metgrid_levels) then  ! Check to make sure that the number of aerosol levels is consistent with the metgrid pressure levels
2619                            CALL wrf_debug (0 , 'Vertically-interpolating QNWFA first guess from WPS data to fill scalar using metgrid pressure field')
2620                            CALL vert_interp ( grid%qnwfa_gc , grid%pd_gc , scalar(:,:,:,P_QNWFA) , grid%pb , &
2621                                               grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2622                                               grid%pmaxwnn , grid%ptropnn , &
2623                                               0 , 0 , &
2624                                               config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2625                                               config_flags%maxw_above_this_level , &
2626                                               config_flags%num_wif_levels , 'Q' , &
2627                                               interp_type , linear_interp , extrap_type , &
2628                                               .false. , use_levels_below_ground , use_surface , &
2629                                               zap_close_levels , force_sfc_in_vinterp , grid%id , &
2630                                               ids , ide , jds , jde , kds , kde , &
2631                                               ims , ime , jms , jme , kms , kme , &
2632                                               its , ite , jts , jte , kts , kte )
2633                         else
2634                            CALL wrf_error_fatal ('num_wif_levels not equal to num_metgrid_levels')
2635                         end if
2636                      end if
2637                   else
2638                      CALL wrf_error_fatal ('mp_physics=28 but there is not QNWFA aerosol information from first guess' )
2639                   end if do_qnwfa
2640
2641                     ! Ice-friendly aerosol
2642                   do_qnifa: if (flag_qnifa .EQ. 1) then
2643                      if (flag_p_wif .EQ. 1) then
2644                         CALL wrf_debug (0 , 'Vertically-interpolating QNIFA first guess from WPS data to fill scalar using native pressure field')
2645                         CALL wrf_debug (0 , 'COMMENT: BE SURE num_wif_levels IN NAMELIST EQUALS num_wif_levels IN MET_EM FILES!')
2646                         CALL vert_interp ( grid%qnifa_gc , grid%p_wif_gc , scalar(:,:,:,P_QNIFA) , grid%pb , &
2647                                            grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2648                                            grid%pmaxwnn , grid%ptropnn , &
2649                                            0 , 0 , &
2650                                            config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2651                                            config_flags%maxw_above_this_level , &
2652                                            config_flags%num_wif_levels , 'Q' , &
2653                                            interp_type , linear_interp , extrap_type , &
2654                                            .false. , use_levels_below_ground , use_surface , &
2655                                            zap_close_levels , force_sfc_in_vinterp , grid%id , &
2656                                            ids , ide , jds , jde , kds , kde , &
2657                                            ims , ime , jms , jme , kms , kme , &
2658                                            its , ite , jts , jte , kts , kte )
2659                      else  ! Interpolate according to metgrid pressure field
2660                         if (config_flags%num_wif_levels .EQ. num_metgrid_levels) then  ! Check to make sure that the number of aerosol levels is consistent with the metgrid pressure levels
2661                            CALL wrf_debug (0 , 'Vertically-interpolating QNIFA first guess from WPS data to fill scalar using metgrid pressure field')
2662                            CALL vert_interp ( grid%qnifa_gc , grid%pd_gc , scalar(:,:,:,P_QNIFA) , grid%pb , &
2663                                               grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2664                                               grid%pmaxwnn , grid%ptropnn , &
2665                                               0 , 0 , &
2666                                               config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2667                                               config_flags%maxw_above_this_level , &
2668                                               config_flags%num_wif_levels , 'Q' , &
2669                                               interp_type , linear_interp , extrap_type , &
2670                                               .false. , use_levels_below_ground , use_surface , &
2671                                               zap_close_levels , force_sfc_in_vinterp , grid%id , &
2672                                               ids , ide , jds , jde , kds , kde , &
2673                                               ims , ime , jms , jme , kms , kme , &
2674                                               its , ite , jts , jte , kts , kte )
2675                         else
2676                            CALL wrf_error_fatal ('num_qnifa_levels not equal to num_metgrid_levels')
2677                         end if
2678                      end if
2679                   else
2680                      CALL wrf_error_fatal ('mp_physics=28 but there is not QNIFA aerosol information from first guess' )
2681                   end if do_qnifa
2682
2683                     ! Black carbon aerosol
2684                   if (config_flags%wif_input_opt .EQ. 2) then
2685                      do_qnbca: if (flag_qnbca .EQ. 1) then
2686                         if (flag_p_wif .EQ. 1) then
2687                            CALL wrf_debug (0 , 'Vertically-interpolating QNBCA first guess from WPS data to fill scalar using native pressure field')
2688                            CALL wrf_debug (0 , 'COMMENT: BE SURE num_wif_levels IN NAMELIST EQUALS num_wif_levels IN MET_EM FILES!')
2689                            CALL vert_interp ( grid%qnbca_gc , grid%p_wif_gc , scalar(:,:,:,P_QNBCA) , grid%pb , &
2690                                               grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2691                                               grid%pmaxwnn , grid%ptropnn , &
2692                                               0 , 0 , &
2693                                               config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2694                                               config_flags%maxw_above_this_level , &
2695                                               config_flags%num_wif_levels , 'Q' , &
2696                                               interp_type , linear_interp , extrap_type , &
2697                                               .false. , use_levels_below_ground , use_surface , &
2698                                               zap_close_levels , force_sfc_in_vinterp , grid%id , &
2699                                               ids , ide , jds , jde , kds , kde , &
2700                                               ims , ime , jms , jme , kms , kme , &
2701                                               its , ite , jts , jte , kts , kte )
2702                         else  ! Interpolate according to metgrid pressure field
2703                            if (config_flags%num_wif_levels .EQ. num_metgrid_levels) then  ! Check to make sure that the number of aerosol levels is consistent with the metgrid pressure levels
2704                               CALL wrf_debug (0 , 'Vertically-interpolating QNBCA first guess from WPS data to fill scalar using metgrid pressure field')
2705                               CALL vert_interp ( grid%qnbca_gc , grid%pd_gc , scalar(:,:,:,P_QNBCA) , grid%pb , &
2706                                                  grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2707                                                  grid%pmaxwnn , grid%ptropnn , &
2708                                                  0 , 0 , &
2709                                                  config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2710                                                  config_flags%maxw_above_this_level , &
2711                                                  config_flags%num_wif_levels , 'Q' , &
2712                                                  interp_type , linear_interp , extrap_type , &
2713                                                  .false. , use_levels_below_ground , use_surface , &
2714                                                  zap_close_levels , force_sfc_in_vinterp , grid%id , &
2715                                                  ids , ide , jds , jde , kds , kde , &
2716                                                  ims , ime , jms , jme , kms , kme , &
2717                                                  its , ite , jts , jte , kts , kte )
2718                            else
2719                               CALL wrf_error_fatal ('num_qnifa_levels not equal to num_metgrid_levels')
2720                            end if
2721                         end if
2722                      else
2723                         CALL wrf_error_fatal ('mp_physics=28 and wif_input_opt=2 but there is not QNBCA aerosol information from first guess' )
2724                      end if do_qnbca
2725                   end if
2726
2727                case default
2728
2729                   CALL wrf_debug (0 , 'aer_init_opt = ', aer_init_opt)
2730                   CALL wrf_error_fatal ('Aerosol forcing option does not exist for mp_physics=28' )
2731
2732                end select select_aer_init_opt_3d
2733
2734             ELSE IF (config_flags%mp_physics .EQ. THOMPSONAERO .and. &
2735                      config_flags%wif_input_opt .EQ. 0 ) THEN
2736                CALL wrf_error_fatal ('wif_input_opt=0 but mp_physics=28' )
2737             END IF if_thompsonaero_3d
2738
2739 !=========================================================================================
2740 !    END OF OPTIONAL 3D DATA, USUALLY AEROSOLS
2741 !=========================================================================================
2742
2743          !  If this is UM data, put the dry rho-based pressure back into the dry pressure array.
2744          !  Since the dry pressure is no longer needed, no biggy.
2745
2746          IF ( flag_ptheta .EQ. 1 ) THEN
2747             DO j = jts, MIN(jte,jde-1)
2748                DO k = 1 , num_metgrid_levels
2749                   DO i = its, MIN(ite,ide-1)
2750                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2751                      grid%pd_gc(i,k,j) = grid%prho_gc(i,k,j)
2752                   END DO
2753                END DO
2754             END DO
2755          END IF
2756
2757 #ifdef DM_PARALLEL
2758          ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte
2759
2760          !  For the U and V vertical interpolation, we need the pressure defined
2761          !  at both the locations for the horizontal momentum, which we get by
2762          !  averaging two pressure values (i and i-1 for U, j and j-1 for V).  The
2763          !  pressure field on input (grid%pd_gc) and the pressure of the new coordinate
2764          !  (grid%pb) would only need an 8 point stencil.  However, the i+1 i-1 and
2765          !  j+1 j-1 for the pressure difference for the max_wind and trop level data
2766          !  require an 8 stencil for all of the mass point variables and a 24-point
2767          !  stencil for U and V.
2768
2769 # include "HALO_EM_VINTERP_UV_1.inc"
2770 #endif
2771
2772          CALL vert_interp ( grid%u_gc , grid%pd_gc , grid%u_2               , grid%pb , &
2773                             grid%umaxw , grid%utrop , grid%pmaxw , grid%ptrop , &
2774                             grid%pmaxwnn , grid%ptropnn , &
2775                             flag_umaxw , flag_utrop , &
2776                             config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2777                             config_flags%maxw_above_this_level , &
2778                             num_metgrid_levels , 'U' , &
2779                             interp_type , lagrange_order , extrap_type , &
2780                             lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
2781                             zap_close_levels , force_sfc_in_vinterp , grid%id , &
2782                             ids , ide , jds , jde , kds , kde , &
2783                             ims , ime , jms , jme , kms , kme , &
2784                             its , ite , jts , jte , kts , kte )
2785
2786          CALL vert_interp ( grid%v_gc , grid%pd_gc , grid%v_2               , grid%pb , &
2787                             grid%vmaxw , grid%vtrop , grid%pmaxw , grid%ptrop , &
2788                             grid%pmaxwnn , grid%ptropnn , &
2789                             flag_vmaxw , flag_vtrop , &
2790                             config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2791                             config_flags%maxw_above_this_level , &
2792                             num_metgrid_levels , 'V' , &
2793                             interp_type , lagrange_order , extrap_type , &
2794                             lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
2795                             zap_close_levels , force_sfc_in_vinterp , grid%id , &
2796                             ids , ide , jds , jde , kds , kde , &
2797                             ims , ime , jms , jme , kms , kme , &
2798                             its , ite , jts , jte , kts , kte )
2799
2800       END IF     !   <----- END OF VERTICAL INTERPOLATION PART ---->
2801
2802       ! Set the temperature of the inland lakes to tavgsfc if the temperature is available
2803       ! and islake is > num_veg_cat
2804
2805       num_veg_cat      = SIZE ( grid%landusef , DIM=2 )
2806       CALL nl_get_iswater ( grid%id , grid%iswater )
2807       CALL nl_get_islake  ( grid%id , grid%islake )
2808
2809
2810       IF ( grid%islake < 0 ) THEN
2811          grid%lakeflag=0
2812          CALL wrf_debug ( 0 , 'Old data, no inland lake information')
2813
2814             DO j=jts,MIN(jde-1,jte)
2815                DO i=its,MIN(ide-1,ite)
2816                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2817                   IF ( ( ( grid%landusef(i,grid%iswater,j) >= 0.5 ) .OR. ( grid%lu_index(i,j) == grid%iswater ) ) .AND. &
2818                        ( ( grid%sst(i,j) .LT. 150 ) .OR. ( grid%sst(i,j) .GT. 400 ) ) ) THEN
2819                      IF ( we_have_tavgsfc ) THEN
2820                         grid%sst(i,j) = grid%tavgsfc(i,j)
2821                      END IF
2822                      IF ( ( grid%sst(i,j) .LT. 150 ) .OR. ( grid%sst(i,j) .GT. 400 ) ) THEN
2823                         grid%sst(i,j) = grid%tsk(i,j)
2824                      END IF
2825                      IF ( ( grid%sst(i,j) .LT. 150 ) .OR. ( grid%sst(i,j) .GT. 400 ) ) THEN
2826                         grid%sst(i,j) = grid%t2(i,j)
2827                      END IF
2828                   END IF
2829                END DO
2830             END DO
2831       ELSE
2832          grid%lakeflag=1
2833          IF ( we_have_tavgsfc ) THEN
2834
2835             CALL wrf_debug ( 0 , 'Using inland lakes with average surface temperature')
2836             DO j=jts,MIN(jde-1,jte)
2837                DO i=its,MIN(ide-1,ite)
2838                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2839                   IF ( ( grid%landusef(i,grid%islake,j) >= 0.5 ) .OR. ( grid%lu_index(i,j) == grid%islake ) )  THEN
2840                      grid%sst(i,j) = grid%tavgsfc(i,j)
2841                      grid%tsk(i,j) = grid%tavgsfc(i,j)
2842                   END IF
2843                   IF ( ( grid%sst(i,j) .LT. 150 ) .OR. ( grid%sst(i,j) .GT. 400 ) ) THEN
2844                      grid%sst(i,j) = grid%t2(i,j)
2845                   END IF
2846                END DO
2847             END DO
2848
2849          ELSE     ! We don't have tavgsfc
2850
2851             CALL wrf_debug ( 0 , 'No average surface temperature for use with inland lakes')
2852
2853          END IF
2854          DO j=jts,MIN(jde-1,jte)
2855             DO i=its,MIN(ide-1,ite)
2856                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2857                grid%landusef(i,grid%iswater,j) = grid%landusef(i,grid%iswater,j) + &
2858                                                  grid%landusef(i,grid%islake,j)
2859                grid%landusef(i,grid%islake,j) = 0.
2860             END DO
2861          END DO
2862          IF ( config_flags%surface_input_source .EQ. 3 ) THEN
2863             DO j=jts,MIN(jde-1,jte)
2864                DO i=its,MIN(ide-1,ite)
2865                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2866                   IF ( grid%lu_index(i,j) .EQ. grid%islake ) THEN
2867                      grid%lu_index(i,j) = grid%iswater
2868                   END IF
2869                END DO
2870             END DO
2871          END IF
2872
2873       END IF
2874
2875       !  Save the grid%tsk field for later use in the sea ice surface temperature
2876       !  for the Noah LSM scheme.
2877
2878       DO j = jts, MIN(jte,jde-1)
2879          DO i = its, MIN(ite,ide-1)
2880             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2881             grid%tsk_save(i,j) = grid%tsk(i,j)
2882          END DO
2883       END DO
2884
2885       !  Protect against bad grid%tsk values over water by supplying grid%sst (if it is
2886       !  available, and if the grid%sst is reasonable).
2887
2888       DO j = jts, MIN(jde-1,jte)
2889          DO i = its, MIN(ide-1,ite)
2890             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2891             IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. &
2892                  ( grid%sst(i,j) .GT. 170. ) .AND. ( grid%sst(i,j) .LT. 400. ) ) THEN
2893                grid%tsk(i,j) = grid%sst(i,j)
2894             ENDIF
2895          END DO
2896       END DO
2897
2898       !  Take the data from the input file and store it in the variables that
2899       !  use the WRF naming and ordering conventions.
2900
2901       DO j = jts, MIN(jte,jde-1)
2902          DO i = its, MIN(ite,ide-1)
2903             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2904             IF ( grid%snow(i,j) .GE. 10. ) then
2905                grid%snowc(i,j) = 1.
2906             ELSE
2907                grid%snowc(i,j) = 0.0
2908             END IF
2909          END DO
2910       END DO
2911
2912       !  Set flag integers for presence of snowh and soilw fields
2913
2914       grid%ifndsnowh = flag_snowh
2915       IF (num_sw_levels_input .GE. 1) THEN
2916          grid%ifndsoilw = 1
2917       ELSE
2918          grid%ifndsoilw = 0
2919       END IF
2920
2921       !  Set flag integers for presence of albsi, snowsi, and icedepth fields
2922
2923       IF ( config_flags%seaice_albedo_opt == 2 ) THEN
2924           grid%ifndalbsi = flag_albsi
2925       ELSE
2926           grid%ifndalbsi = 0
2927       ENDIF
2928
2929       IF ( config_flags%seaice_snowdepth_opt == 1 ) THEN
2930           grid%ifndsnowsi = flag_snowsi
2931       ELSE
2932           grid%ifndsnowsi = 0
2933       ENDIF
2934
2935       IF ( config_flags%seaice_thickness_opt == 1 ) THEN
2936           grid%ifndicedepth = flag_icedepth
2937       ELSE
2938           grid%ifndicedepth = 0
2939       ENDIF
2940
2941       !  Only certain land surface schemes are able to work with the NLCD data.
2942
2943       CALL nl_get_mminlu ( grid%id , mminlu )
2944       write(a_message,*) 'MMINLU = ',trim(mminlu)
2945       CALL wrf_debug ( 1 , a_message )
2946       write(a_message,*) 'sf_surface_physics = ',model_config_rec%sf_surface_physics(grid%id)
2947       CALL wrf_debug ( 1, a_message )
2948
2949       probs_with_nlcd : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
2950
2951          CASE ( RUCLSMSCHEME, NOAHMPSCHEME, CLMSCHEME, SSIBSCHEME )
2952             IF ( TRIM(mminlu) .EQ. 'NLCD40' ) THEN
2953                CALL wrf_message ( 'NLCD40 data may be used with SLABSCHEME, LSMSCHEME, PXLSMSCHEME' )
2954                CALL wrf_message ( 'Re-run geogrid and choose a different land cover source, or select a different sf_surface_physics option' )
2955                CALL wrf_error_fatal ( 'NLCD40 data may not be used with: RUCLSMSCHEME, NOAHMPSCHEME, CLMSCHEME, SSIBSCHEME' )
2956             END IF
2957
2958          CASE ( SLABSCHEME, LSMSCHEME, PXLSMSCHEME )
2959                CALL wrf_debug ( 1, 'NLCD40 being used with an OK scheme' )
2960
2961       END SELECT probs_with_nlcd
2962
2963       !  We require input data for the various LSM schemes.
2964
2965       enough_data : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
2966
2967          CASE ( LSMSCHEME, NOAHMPSCHEME )
2968             IF ( num_st_levels_input .LT. 2 ) THEN
2969                CALL wrf_error_fatal ( 'Not enough soil temperature data for Noah LSM scheme.')
2970             END IF
2971
2972          CASE (RUCLSMSCHEME)
2973             IF ( num_st_levels_input .LT. 2 ) THEN
2974                CALL wrf_error_fatal ( 'Not enough soil temperature data for RUC LSM scheme.')
2975             END IF
2976
2977          CASE (PXLSMSCHEME)
2978             IF ( num_st_levels_input .LT. 2 ) THEN
2979                CALL wrf_error_fatal ( 'Not enough soil temperature data for P-X LSM scheme.')
2980             END IF
2981          CASE (CLMSCHEME)
2982             IF ( num_st_levels_input .LT. 2 ) THEN
2983                CALL wrf_error_fatal ( 'Not enough soil temperature data for CLM LSM scheme.')
2984             END IF
2985 !---------- fds (06/2010) ---------------------------------
2986          CASE (SSIBSCHEME)
2987             IF ( num_st_levels_input .LT. 2 ) THEN
2988                CALL wrf_error_fatal ( 'Not enough soil temperature data for SSIB LSM scheme.')
2989             END IF
2990             IF ( eta_levels(2) .GT. 0.982 ) THEN
2991                CALL wrf_error_fatal ( 'The first two eta levels are too shallow for SSIB LSM scheme.')
2992             END IF
2993 !--------------------------------------------------------
2994
2995       END SELECT enough_data
2996
2997       interpolate_soil_tmw : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
2998
2999          CASE ( SLABSCHEME,LSMSCHEME,NOAHMPSCHEME,RUCLSMSCHEME,PXLSMSCHEME,CLMSCHEME,SSIBSCHEME )
3000             CALL process_soil_real ( grid%tsk , grid%tmn , grid%tavgsfc,  &
3001                                   grid%landmask , grid%sst , grid%ht, grid%toposoil, &
3002                                   st_input , sm_input , sw_input , &
3003                                   st_levels_input , sm_levels_input , sw_levels_input , &
3004                                   grid%zs , grid%dzs , model_config_rec%flag_sm_adj , &
3005                                   grid%tslb , grid%smois , grid%sh2o , &
3006                                   flag_sst , flag_tavgsfc, flag_soilhgt, &
3007                                   flag_soil_layers, flag_soil_levels, &
3008                                   ids , ide , jds , jde , kds , kde , &
3009                                   ims , ime , jms , jme , kms , kme , &
3010                                   its , ite , jts , jte , kts , kte , &
3011                                   model_config_rec%sf_surface_physics(grid%id) , &
3012                                   model_config_rec%num_soil_layers , &
3013                                   model_config_rec%real_data_init_type , &
3014                                   num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
3015                                   num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc )
3016
3017       END SELECT interpolate_soil_tmw
3018
3019       !  surface_input_source=1 => use data from static file (fractional category as input)
3020       !  surface_input_source=2 => use data from grib file (dominant category as input)
3021       !  surface_input_source=3 => use dominant data from static file (dominant category as input)
3022
3023       IF ( any_valid_points ) THEN
3024       IF ( config_flags%surface_input_source .EQ. 1 ) THEN
3025
3026       !  Generate the vegetation and soil category information from the fractional input
3027       !  data, or use the existing dominant category fields if they exist.
3028
3029          grid%vegcat (its,jts) = 0
3030          grid%soilcat(its,jts) = 0
3031
3032          num_veg_cat      = SIZE ( grid%landusef , DIM=2 )
3033          num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 )
3034          num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 )
3035
3036          CALL process_percent_cat_new ( grid%landmask , &
3037                                     grid%landusef , grid%soilctop , grid%soilcbot , &
3038                                     grid%isltyp , grid%ivgtyp , &
3039                                     num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
3040                                     ids , ide , jds , jde , kds , kde , &
3041                                     ims , ime , jms , jme , kms , kme , &
3042                                     its , ite , jts , jte , kts , kte , &
3043                                     model_config_rec%iswater(grid%id) )
3044
3045          !  Make all the veg/soil parms the same so as not to confuse the developer.
3046
3047
3048          DO j = jts , MIN(jde-1,jte)
3049             DO i = its , MIN(ide-1,ite)
3050                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3051                grid%vegcat(i,j)  = grid%ivgtyp(i,j)
3052                grid%soilcat(i,j) = grid%isltyp(i,j)
3053             END DO
3054          END DO
3055
3056       ELSE IF ( config_flags%surface_input_source .EQ. 2 ) THEN
3057
3058          !  Do we have dominant soil and veg data from the input already?
3059
3060          IF ( grid%soilcat(i_valid,j_valid) .GT. 0.5 ) THEN
3061             DO j = jts, MIN(jde-1,jte)
3062                DO i = its, MIN(ide-1,ite)
3063                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3064                   grid%isltyp(i,j) = NINT( grid%soilcat(i,j) )
3065                END DO
3066             END DO
3067          END IF
3068          IF ( grid%vegcat(i_valid,j_valid) .GT. 0.5 ) THEN
3069             DO j = jts, MIN(jde-1,jte)
3070                DO i = its, MIN(ide-1,ite)
3071                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3072                   grid%ivgtyp(i,j) = NINT( grid%vegcat(i,j) )
3073                END DO
3074             END DO
3075          END IF
3076
3077       ELSE IF ( config_flags%surface_input_source .EQ. 3 ) THEN
3078
3079          !  Do we have dominant soil and veg data from the static input already?
3080
3081          IF ( grid%sct_dom_gc(i_valid,j_valid) .GT. 0.5 ) THEN
3082             DO j = jts, MIN(jde-1,jte)
3083                DO i = its, MIN(ide-1,ite)
3084                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3085                   grid%isltyp(i,j) = NINT( grid%sct_dom_gc(i,j) )
3086                   grid%soilcat(i,j) = grid%isltyp(i,j)
3087                END DO
3088             END DO
3089          ELSE
3090             WRITE ( a_message , * ) 'You have set surface_input_source = 3,'// &
3091                                     ' but your geogrid data does not have valid dominant soil data.'
3092             CALL wrf_error_fatal ( a_message )
3093          END IF
3094          IF ( grid%lu_index(i_valid,j_valid) .GT. 0.5 ) THEN
3095             DO j = jts, MIN(jde-1,jte)
3096                DO i = its, MIN(ide-1,ite)
3097                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3098                   grid%ivgtyp(i,j) = NINT( grid%lu_index(i,j) )
3099                   grid%vegcat(i,j) = grid%ivgtyp(i,j)
3100                END DO
3101             END DO
3102          ELSE
3103             WRITE ( a_message , * ) 'You have set surface_input_source = 3,'//&
3104                                     ' but your geogrid data does not have valid dominant land use data.'
3105             CALL wrf_error_fatal ( a_message )
3106          END IF
3107
3108          !  Need to match isltyp to landmask
3109
3110          iforce = 0
3111          change_soil = 0
3112          change_soilw = 0
3113          DO j = jts, MIN(jde-1,jte)
3114             DO i = its, MIN(ide-1,ite)
3115                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3116                IF ( grid%landmask(i,j) .GT. 0.5 .AND. grid%isltyp(i,j) .EQ. grid%isoilwater ) THEN
3117                   grid%isltyp(i,j) = 8
3118                   change_soilw =  change_soilw + 1
3119                   iforce =  iforce + 1
3120                ELSE IF ( grid%landmask(i,j) .LT. 0.5 .AND. grid%isltyp(i,j) .NE. grid%isoilwater ) THEN
3121                   grid%isltyp(i,j) = grid%isoilwater
3122                   change_soil =  change_soil + 1
3123                   iforce =  iforce + 1
3124                END IF
3125             END DO
3126          END DO
3127          IF ( change_soilw .GT. 0 .OR. change_soil .GT. 0 ) THEN
3128             WRITE(a_message,FMT='(A,I4,A,I6)' ) &
3129                   'forcing artificial silty clay loam at ',iforce,' points, out of ',&
3130                   (MIN(ide-1,ite)-its+1)*(MIN(jde-1,jte)-jts+1)
3131                   CALL wrf_debug(0,a_message)
3132          END IF
3133
3134       END IF
3135
3136       !  Split NUDAPT  Urban Parameters
3137
3138       distributed_aerodynamics_if: IF (config_flags%sf_urban_physics == 1 .AND. config_flags%slucm_distributed_drag) THEN
3139          CALL nl_get_isurban ( grid%id , grid%isurban )
3140          DO j = jts , MIN(jde-1,jte)
3141             DO i = its , MIN(ide-1,ite)
3142               IF (grid%landusef(i, grid%isurban, j) > 0) THEN
3143                 grid%frc_urb2d(i, j) = MAX(0.1, MIN(0.9, 1 - grid%shdavg(i, j) / 100.))
3144               END IF
3145             END DO
3146           END DO
3147       ELSE
3148
3149        IF ( ( config_flags%sf_urban_physics == 1 ) .OR. ( config_flags%sf_urban_physics == 2 ) .OR. ( config_flags%sf_urban_physics == 3 ) ) THEN
3150          DO j = jts , MIN(jde-1,jte)
3151             DO i = its , MIN(ide-1,ite)
3152               IF ( MMINLU == 'NLCD40' .OR. MMINLU == 'MODIFIED_IGBP_MODIS_NOAH') THEN
3153                   IF ( grid%FRC_URB2D(i,j) .GE. 0.5 .AND.  &
3154                       (grid%ivgtyp(i,j).NE.13 .AND. grid%ivgtyp(i,j).NE.24 .AND. grid%ivgtyp(i,j).NE.25 .AND. grid%ivgtyp(i,j).NE.26 .AND. grid%ivgtyp(i,j).LT.30)) grid%ivgtyp(i,j)=13
3155               ELSE IF ( MMINLU == "USGS" ) THEN
3156                   IF ( grid%FRC_URB2D(i,j) .GE. 0.5 .AND.  &
3157                        grid%ivgtyp(i,j).NE.1 ) grid%ivgtyp(i,j)=1
3158               ENDIF
3159
3160               IF ( grid%FRC_URB2D(i,j) == 0. ) THEN
3161                  IF ( (MMINLU == 'NLCD40' .OR. MMINLU == 'MODIFIED_IGBP_MODIS_NOAH') .AND. &
3162                    (grid%ivgtyp(i,j)==24 .OR. grid%ivgtyp(i,j)==25 .OR. grid%ivgtyp(i,j)==26 .OR. grid%ivgtyp(i,j)==13) ) grid%FRC_URB2D(i,j) = 0.9
3163                  IF ( MMINLU == 'USGS' .AND. grid%ivgtyp(i,j)==1 ) grid%FRC_URB2D(i,j) = 0.9
3164               ENDIF
3165                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3166                grid%LP_URB2D(i,j)  = grid%URB_PARAM(i,91,j)
3167                grid%LB_URB2D(i,j)  = grid%URB_PARAM(i,95,j)
3168                grid%HGT_URB2D(i,j)  = grid%URB_PARAM(i,94,j)
3169             END DO
3170          END DO
3171        ENDIF
3172
3173       IF ( ( config_flags%sf_urban_physics == 2 ) .OR. ( config_flags%sf_urban_physics == 3 ) ) THEN
3174          DO j = jts , MIN(jde-1,jte)
3175             DO i = its , MIN(ide-1,ite)
3176                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3177                DO k = 1, 15
3178                   grid%HI_URB2D(i,k,j)  = grid%URB_PARAM(i,k+117,j)
3179                END DO
3180             END DO
3181          END DO
3182       ENDIF
3183
3184       DO j = jts , MIN(jde-1,jte)
3185          DO i = its , MIN(ide-1,ite)
3186             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3187             IF ( config_flags%sf_urban_physics==1 ) THEN
3188                grid%MH_URB2D(i,j)  = grid%URB_PARAM(i,92,j)
3189                grid%STDH_URB2D(i,j)  = grid%URB_PARAM(i,93,j)
3190             ENDIF
3191          END DO
3192       END DO
3193
3194       DO  j = jts , MIN(jde-1,jte)
3195          DO i = its , MIN(ide-1,ite)
3196             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3197             DO k = 1, 4
3198                IF ( config_flags%sf_urban_physics==1 ) THEN
3199                   grid%LF_URB2D(i,k,j)  = grid%URB_PARAM(i,k+95,j)
3200                ENDIF
3201             END DO
3202          END DO
3203       END DO
3204
3205       END IF distributed_aerodynamics_if
3206
3207       END IF
3208
3209       !  Adjustments for the seaice field PRIOR to the grid%tslb computations.  This is
3210       !  is for the 5-layer scheme.
3211
3212
3213       num_veg_cat      = SIZE ( grid%landusef , DIM=2 )
3214       num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 )
3215       num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 )
3216       CALL nl_get_seaice_threshold ( grid%id , grid%seaice_threshold )
3217       CALL nl_get_isice ( grid%id , grid%isice )
3218       CALL nl_get_iswater ( grid%id , grid%iswater )
3219       CALL adjust_for_seaice_pre ( grid%xice , grid%landmask , grid%tsk , grid%ivgtyp , grid%vegcat , grid%lu_index , &
3220                                    grid%xland , grid%landusef , grid%isltyp , grid%soilcat , grid%soilctop , &
3221                                    grid%soilcbot , grid%tmn , &
3222                                    grid%seaice_threshold , &
3223                                    config_flags%fractional_seaice, &
3224                                    num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
3225                                    grid%iswater , grid%isice , &
3226                                    model_config_rec%sf_surface_physics(grid%id) , &
3227                                    ids , ide , jds , jde , kds , kde , &
3228                                    ims , ime , jms , jme , kms , kme , &
3229                                    its , ite , jts , jte , kts , kte )
3230
3231       !  Land use assignment.
3232
3233       DO j = jts, MIN(jde-1,jte)
3234          DO i = its, MIN(ide-1,ite)
3235             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3236             grid%lu_index(i,j) = grid%ivgtyp(i,j)
3237             IF ( grid%lu_index(i,j) .NE. model_config_rec%iswater(grid%id) ) THEN
3238                grid%landmask(i,j) = 1
3239                grid%xland(i,j)    = 1
3240             ELSE
3241                grid%landmask(i,j) = 0
3242                grid%xland(i,j)    = 2
3243             END IF
3244          END DO
3245       END DO
3246
3247
3248       !  Fix grid%tmn and grid%tsk.
3249
3250       fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
3251
3252          CASE ( SLABSCHEME , LSMSCHEME , NOAHMPSCHEME , RUCLSMSCHEME, PXLSMSCHEME,CLMSCHEME, CTSMSCHEME, SSIBSCHEME )
3253             DO j = jts, MIN(jde-1,jte)
3254                DO i = its, MIN(ide-1,ite)
3255                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3256                   IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. &
3257                        ( grid%sst(i,j) .GT. 170. ) .AND. ( grid%sst(i,j) .LT. 400. ) ) THEN
3258                      grid%tmn(i,j) = grid%sst(i,j)
3259                      grid%tsk(i,j) = grid%sst(i,j)
3260                   ELSE IF ( grid%landmask(i,j) .LT. 0.5 ) THEN
3261                      grid%tmn(i,j) = grid%tsk(i,j)
3262                   END IF
3263                END DO
3264             END DO
3265       END SELECT fix_tsk_tmn
3266
3267       !  Is the grid%tsk reasonable?
3268
3269       IF ( internal_time_loop .NE. 1 ) THEN
3270          DO j = jts, MIN(jde-1,jte)
3271             DO i = its, MIN(ide-1,ite)
3272                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3273                IF ( grid%tsk(i,j) .LT. 170 .or. grid%tsk(i,j) .GT. 400. ) THEN
3274                   grid%tsk(i,j) = grid%t_2(i,1,j)
3275                END IF
3276             END DO
3277          END DO
3278       ELSE
3279          DO j = jts, MIN(jde-1,jte)
3280             DO i = its, MIN(ide-1,ite)
3281                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3282                IF ( grid%tsk(i,j) .LT. 170 .or. grid%tsk(i,j) .GT. 400. ) THEN
3283                   print *,'error in the grid%tsk'
3284                   print *,'i,j=',i,j
3285                   print *,'grid%landmask=',grid%landmask(i,j)
3286                   print *,'grid%tsk, grid%sst, grid%tmn=',grid%tsk(i,j),grid%sst(i,j),grid%tmn(i,j)
3287                   if(grid%tmn(i,j).gt.170. .and. grid%tmn(i,j).lt.400.)then
3288                      grid%tsk(i,j)=grid%tmn(i,j)
3289                   else if(grid%sst(i,j).gt.170. .and. grid%sst(i,j).lt.400.)then
3290                      grid%tsk(i,j)=grid%sst(i,j)
3291                   else
3292                      CALL wrf_error_fatal ( 'grid%tsk unreasonable' )
3293                   end if
3294                END IF
3295             END DO
3296          END DO
3297       END IF
3298
3299       !  Is the grid%tmn reasonable?
3300
3301       DO j = jts, MIN(jde-1,jte)
3302          DO i = its, MIN(ide-1,ite)
3303             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3304             IF ( ( ( grid%tmn(i,j) .LT. 170. ) .OR. ( grid%tmn(i,j) .GT. 400. ) ) &
3305                .AND. ( grid%landmask(i,j) .GT. 0.5 ) ) THEN
3306                IF ( ( model_config_rec%sf_surface_physics(grid%id) .NE. LSMSCHEME ) .and. &
3307                     ( model_config_rec%sf_surface_physics(grid%id) .NE. NOAHMPSCHEME ) ) THEN
3308                   print *,'error in the grid%tmn'
3309                   print *,'i,j=',i,j
3310                   print *,'grid%landmask=',grid%landmask(i,j)
3311                   print *,'grid%tsk, grid%sst, grid%tmn=',grid%tsk(i,j),grid%sst(i,j),grid%tmn(i,j)
3312                END IF
3313
3314                if(grid%tsk(i,j).gt.170. .and. grid%tsk(i,j).lt.400.)then
3315                   grid%tmn(i,j)=grid%tsk(i,j)
3316                else if(grid%sst(i,j).gt.170. .and. grid%sst(i,j).lt.400.)then
3317                   grid%tmn(i,j)=grid%sst(i,j)
3318                else
3319                   CALL wrf_error_fatal ( 'grid%tmn unreasonable' )
3320                endif
3321             END IF
3322          END DO
3323       END DO
3324
3325
3326       !  Minimum soil values, residual, from RUC LSM scheme.  For input from Noah or EC, and using
3327       !  RUC LSM scheme, this must be subtracted from the input total soil moisture.  For
3328       !  input RUC data and using the Noah LSM scheme, this value must be added to the soil
3329       !  moisture input.
3330
3331       lqmi(1:num_soil_top_cat) = &
3332       (/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10,     &
3333         0.089, 0.095, 0.10,  0.070, 0.068, 0.078, 0.0,      &
3334         0.004, 0.065 /)
3335 !       0.004, 0.065, 0.020, 0.004, 0.008 /)  !  has extra levels for playa, lava, and white sand
3336
3337       ! If Unified Model soil moisture input, add lqmi since UM gives us available soil moisture, not total (AFWA source)
3338       IF ( flag_um_soil == 1 ) THEN
3339          DO j = jts, MIN(jde-1,jte)
3340             DO i = its, MIN(ide-1,ite)
3341                grid%smois(i,:,j)=grid%smois(i,:,j)+lqmi(grid%isltyp(i,j))
3342             END DO
3343          END DO
3344       END IF
3345
3346       !  At the initial time we care about values of soil moisture and temperature, other times are
3347       !  ignored by the model, so we ignore them, too.
3348
3349       IF ( domain_ClockIsStartTime(grid) ) THEN
3350          account_for_zero_soil_moisture : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
3351
3352             CASE ( LSMSCHEME , NOAHMPSCHEME )
3353                iicount = 0
3354                IF      ( flag_soil_layers == 1 ) THEN
3355                   DO j = jts, MIN(jde-1,jte)
3356                      DO i = its, MIN(ide-1,ite)
3357                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3358                         IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .and. &
3359                              ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then
3360                            print *,'Noah -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j)
3361                            iicount = iicount + 1
3362
3363                            grid%smois(i,:,j) = 0.005
3364 !+---+-----------------------------------------------------------------+
3365 !  Some bad values of soil moisture are possible (huge negative and positive), but they
3366 !  appear to occur only along coastlines, so instead of overwriting with small moisture
3367 !  values, use relatively large moisture val.  Orig code checked for large negative but
3368 !  not positive values, mods here reset either.  G. Thompson (28 Feb 2008).
3369
3370 !                          grid%smois(i,:,j) = 0.499
3371 !                       ELSEIF ( (grid%landmask(i,j).gt.0.5) .and. (grid%tslb(i,1,j) .gt. 170 ) .and. &
3372 !                            ( grid%tslb(i,1,j) .lt. 400 ) .and. (grid%smois(i,1,j) .gt. 1.005 ) ) then
3373 !                          print *,'Noah -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j)
3374 !                          iicount = iicount + 1
3375 !                          grid%smois(i,:,j) = 0.499
3376 !+---+-----------------------------------------------------------------+
3377                         END IF
3378                      END DO
3379                   END DO
3380                   IF ( iicount .GT. 0 ) THEN
3381                      print *,'Noah -> Noah: total number of small soil moisture locations = ',iicount
3382                   END IF
3383                ELSE IF ( flag_soil_levels == 1 ) THEN
3384                   DO j = jts, MIN(jde-1,jte)
3385                      DO i = its, MIN(ide-1,ite)
3386                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3387                         grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) , 0.005 )
3388 !                        grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) + lqmi(grid%isltyp(i,j)) , 0.005 )
3389                      END DO
3390                   END DO
3391                   DO j = jts, MIN(jde-1,jte)
3392                      DO i = its, MIN(ide-1,ite)
3393                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3394                         IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .and. &
3395                              ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then
3396                            print *,'RUC -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j)
3397                            iicount = iicount + 1
3398                            grid%smois(i,:,j) = 0.005
3399 !+---+-----------------------------------------------------------------+
3400 !  Same comment as above.
3401 !                          grid%smois(i,:,j) = 0.499
3402 !                       ELSEIF ( (grid%landmask(i,j).gt.0.5) .and. (grid%tslb(i,1,j) .gt. 170 ) .and. &
3403 !                            ( grid%tslb(i,1,j) .lt. 400 ) .and. (grid%smois(i,1,j) .gt. 1.005 ) ) then
3404 !                          print *,'Noah -> Noah: bad soil moisture at i,j =',i,j,grid%smois(i,:,j)
3405 !                          iicount = iicount + 1
3406 !                          grid%smois(i,:,j) = 0.499
3407 !+---+-----------------------------------------------------------------+
3408                         END IF
3409                      END DO
3410                   END DO
3411                   IF ( iicount .GT. 0 ) THEN
3412                      print *,'RUC -> Noah: total number of small soil moisture locations = ',iicount
3413                   END IF
3414                END IF
3415
3416 !+---+-----------------------------------------------------------------+
3417                !  Fudge soil moisture higher where canopy water is non-zero.
3418                !  G. Thompson (12 Jun 2008)
3419
3420 !              DO j = jts, MIN(jte,jde-1)
3421 !                DO i = its, MIN(ite,ide-1)
3422 !                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3423 !                   if (grid%canwat(i,j) .GT. 1.01 .AND. grid%landmask(i,j) .GT. 0.5 ) THEN
3424 !                      print *,'  CANWAT: moisten soil a bit more at i,j =',i,j,grid%canwat(i,j)
3425 !                      grid%smois(i,1,j) = grid%smois(i,1,j) + (grid%canwat(i,j)**0.33333)*0.04
3426 !                      grid%smois(i,1,j) = MIN(0.499, grid%smois(i,1,j))
3427 !                      grid%smois(i,2,j) = grid%smois(i,2,j) + (grid%canwat(i,j)**0.33333)*0.01
3428 !                      grid%smois(i,2,j) = MIN(0.499, grid%smois(i,2,j))
3429 !                   end if
3430 !                END DO
3431 !              END DO
3432 !+---+-----------------------------------------------------------------+
3433
3434
3435             CASE ( RUCLSMSCHEME )
3436                iicount = 0
3437                IF      ( flag_soil_layers == 1 ) THEN
3438                   DO j = jts, MIN(jde-1,jte)
3439                      DO i = its, MIN(ide-1,ite)
3440                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3441                         grid%smois(i,:,j) = MAX ( grid%smois(i,:,j)  , 0.005 )
3442 !                        grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) - lqmi(grid%isltyp(i,j)) , 0.005 )
3443                      END DO
3444                   END DO
3445                ELSE IF ( flag_soil_levels == 1 ) THEN
3446                   ! no op
3447                END IF
3448
3449              CASE ( PXLSMSCHEME )
3450                iicount = 0
3451                IF ( flag_soil_layers == 1 ) THEN
3452                   ! no op
3453                ELSE IF ( flag_soil_levels == 1 ) THEN
3454                   DO j = jts, MIN(jde-1,jte)
3455                      DO i = its, MIN(ide-1,ite)
3456                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3457                         grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) , 0.005 )
3458 !                        grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) + lqmi(grid%isltyp(i,j)) , 0.005 )
3459                      END DO
3460                   END DO
3461                END IF
3462             CASE ( CLMSCHEME )
3463                iicount = 0
3464                IF      ( flag_soil_layers == 1 ) THEN
3465                   DO j = jts, MIN(jde-1,jte)
3466                      DO i = its, MIN(ide-1,ite)
3467                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3468                         IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .and. &
3469                              ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then
3470                            print *,'CLM -> CLM: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j)
3471                            iicount = iicount + 1
3472                            grid%smois(i,:,j) = 0.005
3473                         END IF
3474                      END DO
3475                   END DO
3476                   IF ( iicount .GT. 0 ) THEN
3477                      print *,'CLM -> CLM: total number of small soil moisture locations = ',iicount
3478                   END IF
3479                ELSE IF ( flag_soil_levels == 1 ) THEN
3480                   DO j = jts, MIN(jde-1,jte)
3481                      DO i = its, MIN(ide-1,ite)
3482                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3483                         grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) + lqmi(grid%isltyp(i,j)) , 0.005 )
3484                      END DO
3485                   END DO
3486                   DO j = jts, MIN(jde-1,jte)
3487                      DO i = its, MIN(ide-1,ite)
3488                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3489                         IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .and. &
3490                              ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then
3491                            print *,'CLM -> CLM: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j)
3492                            iicount = iicount + 1
3493                            grid%smois(i,:,j) = 0.005
3494                         END IF
3495                      END DO
3496                   END DO
3497                   IF ( iicount .GT. 0 ) THEN
3498                      print *,'CLM -> CLM: total number of small soil moisture locations = ',iicount
3499                   END IF
3500                END IF
3501
3502          END SELECT account_for_zero_soil_moisture
3503       END IF
3504
3505       !  Is the grid%tslb reasonable?
3506
3507       IF ( internal_time_loop .NE. 1 ) THEN
3508          DO j = jts, MIN(jde-1,jte)
3509             DO ns = 1 , model_config_rec%num_soil_layers
3510                DO i = its, MIN(ide-1,ite)
3511                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3512                   IF ( grid%tslb(i,ns,j) .LT. 170 .or. grid%tslb(i,ns,j) .GT. 400. ) THEN
3513                      grid%tslb(i,ns,j) = grid%t_2(i,1,j)
3514                      grid%smois(i,ns,j) = 0.3
3515                   END IF
3516                END DO
3517             END DO
3518          END DO
3519       ELSE
3520          DO j = jts, MIN(jde-1,jte)
3521             DO i = its, MIN(ide-1,ite)
3522                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3523                IF ( ( ( grid%tslb(i,1,j) .LT. 170. ) .OR. ( grid%tslb(i,1,j) .GT. 400. ) ) .AND. &
3524                        ( grid%landmask(i,j) .GT. 0.5 ) ) THEN
3525                      IF ( ( model_config_rec%sf_surface_physics(grid%id) .NE. LSMSCHEME    ) .AND. &
3526                           ( model_config_rec%sf_surface_physics(grid%id) .NE. NOAHMPSCHEME ) .AND. &
3527                           ( model_config_rec%sf_surface_physics(grid%id) .NE. RUCLSMSCHEME ).AND. &
3528                           ( model_config_rec%sf_surface_physics(grid%id) .NE. SSIBSCHEME ).AND. & !fds
3529                           ( model_config_rec%sf_surface_physics(grid%id) .NE. CLMSCHEME ).AND. &
3530                           ( model_config_rec%sf_surface_physics(grid%id) .NE. CTSMSCHEME ).AND. &
3531                           ( model_config_rec%sf_surface_physics(grid%id) .NE. PXLSMSCHEME ) ) THEN
3532                         print *,'error in the grid%tslb'
3533                         print *,'i,j=',i,j
3534                         print *,'grid%landmask=',grid%landmask(i,j)
3535                         print *,'grid%tsk, grid%sst, grid%tmn=',grid%tsk(i,j),grid%sst(i,j),grid%tmn(i,j)
3536                         print *,'grid%tslb = ',grid%tslb(i,:,j)
3537                         print *,'old grid%smois = ',grid%smois(i,:,j)
3538                         grid%smois(i,1,j) = 0.3
3539                         grid%smois(i,2,j) = 0.3
3540                         grid%smois(i,3,j) = 0.3
3541                         grid%smois(i,4,j) = 0.3
3542                      END IF
3543
3544                      IF ( (grid%tsk(i,j).GT.170. .AND. grid%tsk(i,j).LT.400.) .AND. &
3545                           (grid%tmn(i,j).GT.170. .AND. grid%tmn(i,j).LT.400.) ) THEN
3546                         fake_soil_temp : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
3547                            CASE ( SLABSCHEME )
3548                               DO ns = 1 , model_config_rec%num_soil_layers
3549                                  grid%tslb(i,ns,j) = ( grid%tsk(i,j)*(3.0 - grid%zs(ns)) + &
3550                                                        grid%tmn(i,j)*(0.0 - grid%zs(ns)) ) /(3.0 - 0.0)
3551                               END DO
3552                            CASE ( LSMSCHEME , NOAHMPSCHEME , RUCLSMSCHEME, PXLSMSCHEME,CLMSCHEME, CTSMSCHEME, SSIBSCHEME )
3553 !                             CALL wrf_error_fatal ( 'Assigned constant soil moisture to 0.3, stopping')
3554                               DO ns = 1 , model_config_rec%num_soil_layers
3555                                  grid%tslb(i,ns,j) = ( grid%tsk(i,j)*(3.0 - grid%zs(ns)) + &
3556                                                        grid%tmn(i,j)*(0.0 - grid%zs(ns)) ) /(3.0 - 0.0)
3557                               END DO
3558                         END SELECT fake_soil_temp
3559                      else if(grid%tsk(i,j).gt.170. .and. grid%tsk(i,j).lt.400.)then
3560                         CALL wrf_error_fatal ( 'grid%tslb unreasonable 1' )
3561                         DO ns = 1 , model_config_rec%num_soil_layers
3562                            grid%tslb(i,ns,j)=grid%tsk(i,j)
3563                         END DO
3564                      else if(grid%sst(i,j).gt.170. .and. grid%sst(i,j).lt.400.)then
3565                         CALL wrf_error_fatal ( 'grid%tslb unreasonable 2' )
3566                         DO ns = 1 , model_config_rec%num_soil_layers
3567                            grid%tslb(i,ns,j)=grid%sst(i,j)
3568                         END DO
3569                      else if(grid%tmn(i,j).gt.170. .and. grid%tmn(i,j).lt.400.)then
3570                         CALL wrf_error_fatal ( 'grid%tslb unreasonable 3' )
3571                         DO ns = 1 , model_config_rec%num_soil_layers
3572                            grid%tslb(i,ns,j)=grid%tmn(i,j)
3573                         END DO
3574                      else
3575                         CALL wrf_error_fatal ( 'grid%tslb unreasonable 4' )
3576                      endif
3577                END IF
3578             END DO
3579          END DO
3580       END IF
3581
3582       !  Adjustments for the seaice field AFTER the grid%tslb computations.  This is
3583       !  is for the Noah LSM scheme.
3584
3585       num_veg_cat      = SIZE ( grid%landusef , DIM=2 )
3586       num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 )
3587       num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 )
3588       CALL nl_get_seaice_threshold ( grid%id , grid%seaice_threshold )
3589       CALL nl_get_isice ( grid%id , grid%isice )
3590       CALL nl_get_iswater ( grid%id , grid%iswater )
3591       CALL adjust_for_seaice_post ( grid%xice , grid%landmask , grid%tsk , grid%tsk_save , &
3592                                     grid%ivgtyp , grid%vegcat , grid%lu_index , &
3593                                     grid%xland , grid%landusef , grid%isltyp , grid%soilcat ,  &
3594                                     grid%soilctop , &
3595                                     grid%soilcbot , grid%tmn , grid%vegfra , &
3596                                     grid%tslb , grid%smois , grid%sh2o , &
3597                                     grid%seaice_threshold , &
3598                                     grid%sst,flag_sst, &
3599                                     config_flags%fractional_seaice, &
3600                                     num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
3601                                     model_config_rec%num_soil_layers , &
3602                                     grid%iswater , grid%isice , &
3603                                     model_config_rec%sf_surface_physics(grid%id) , &
3604                                     ids , ide , jds , jde , kds , kde , &
3605                                     ims , ime , jms , jme , kms , kme , &
3606                                     its , ite , jts , jte , kts , kte )
3607
3608       !  Let us make sure (again) that the grid%landmask and the veg/soil categories match.
3609
3610 oops1=0
3611 oops2=0
3612       DO j = jts, MIN(jde-1,jte)
3613          DO i = its, MIN(ide-1,ite)
3614             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3615             IF ( ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. &
3616                    ( grid%ivgtyp(i,j) .NE. config_flags%iswater .OR. grid%isltyp(i,j) .NE. 14 ) ) .OR. &
3617                  ( ( grid%landmask(i,j) .GT. 0.5 ) .AND. &
3618                    ( grid%ivgtyp(i,j) .EQ. config_flags%iswater .OR. grid%isltyp(i,j) .EQ. 14 ) ) ) THEN
3619                IF ( grid%tslb(i,1,j) .GT. 1. ) THEN
3620 oops1=oops1+1
3621                   grid%ivgtyp(i,j) = 5
3622                   grid%isltyp(i,j) = 8
3623                   grid%landmask(i,j) = 1
3624                   grid%xland(i,j) = 1
3625                ELSE IF ( grid%sst(i,j) .GT. 1. ) THEN
3626 oops2=oops2+1
3627                   grid%ivgtyp(i,j) = config_flags%iswater
3628                   grid%isltyp(i,j) = 14
3629                   grid%landmask(i,j) = 0
3630                   grid%xland(i,j) = 2
3631                ELSE
3632                   print *,'the grid%landmask and soil/veg cats do not match'
3633                   print *,'i,j=',i,j
3634                   print *,'grid%landmask=',grid%landmask(i,j)
3635                   print *,'grid%ivgtyp=',grid%ivgtyp(i,j)
3636                   print *,'grid%isltyp=',grid%isltyp(i,j)
3637                   print *,'iswater=', config_flags%iswater
3638                   print *,'grid%tslb=',grid%tslb(i,:,j)
3639                   print *,'grid%sst=',grid%sst(i,j)
3640                   CALL wrf_error_fatal ( 'mismatch_landmask_ivgtyp' )
3641                END IF
3642             END IF
3643          END DO
3644       END DO
3645 if (oops1.gt.0) then
3646 print *,'points artificially set to land : ',oops1
3647 endif
3648 if(oops2.gt.0) then
3649 print *,'points artificially set to water: ',oops2
3650 endif
3651 ! fill grid%sst array with grid%tsk if missing in real input (needed for time-varying grid%sst in wrf)
3652       DO j = jts, MIN(jde-1,jte)
3653          DO i = its, MIN(ide-1,ite)
3654            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3655            IF ( flag_sst .NE. 1 ) THEN
3656              grid%sst(i,j) = grid%tsk(i,j)
3657            ENDIF
3658          END DO
3659       END DO
3660 !tgs set snoalb to land value if the water point is covered with ice
3661       DO j = jts, MIN(jde-1,jte)
3662          DO i = its, MIN(ide-1,ite)
3663            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3664            IF ( grid%ivgtyp(i,j) .EQ. config_flags%isice) THEN
3665              grid%snoalb(i,j) = 0.75
3666            ENDIF
3667          END DO
3668       END DO
3669
3670       !  From the full level data, we can get the half levels, reciprocals, and layer
3671       !  thicknesses.  These are all defined at half level locations, so one less level.
3672       !  We allow the vertical coordinate to *accidently* come in upside down.  We want
3673       !  the first full level to be the ground surface.
3674
3675       !  Check whether grid%znw (full level) data are truly full levels. If not, we need to adjust them
3676       !  to be full levels.
3677       !  in this test, we check if grid%znw(1) is neither 0 nor 1 (within a tolerance of 10**-5)
3678
3679       were_bad = .false.
3680       IF ( ( (grid%znw(1).LT.(1-1.E-5) ) .OR. ( grid%znw(1).GT.(1+1.E-5) ) ).AND. &
3681            ( (grid%znw(1).LT.(0-1.E-5) ) .OR. ( grid%znw(1).GT.(0+1.E-5) ) ) ) THEN
3682          were_bad = .true.
3683          print *,'Your grid%znw input values are probably half-levels. '
3684          print *,grid%znw
3685          print *,'WRF expects grid%znw values to be full levels. '
3686          print *,'Adjusting now to full levels...'
3687          !  We want to ignore the first value if it's negative
3688          IF (grid%znw(1).LT.0) THEN
3689             grid%znw(1)=0
3690          END IF
3691          DO k=2,kde
3692             grid%znw(k)=2*grid%znw(k)-grid%znw(k-1)
3693          END DO
3694       END IF
3695
3696       !  Let's check our changes
3697
3698       IF ( ( ( grid%znw(1) .LT. (1-1.E-5) ) .OR. ( grid%znw(1) .GT. (1+1.E-5) ) ).AND. &
3699            ( ( grid%znw(1) .LT. (0-1.E-5) ) .OR. ( grid%znw(1) .GT. (0+1.E-5) ) ) ) THEN
3700          print *,'The input grid%znw height values were half-levels or erroneous. '
3701          print *,'Attempts to treat the values as half-levels and change them '
3702          print *,'to valid full levels failed.'
3703          CALL wrf_error_fatal("bad grid%znw values from input files")
3704       ELSE IF ( were_bad ) THEN
3705          print *,'...adjusted. grid%znw array now contains full eta level values. '
3706       ENDIF
3707
3708       IF ( grid%znw(1) .LT. grid%znw(kde) ) THEN
3709          DO k=1, kde/2
3710             hold_znw = grid%znw(k)
3711             grid%znw(k)=grid%znw(kde+1-k)
3712             grid%znw(kde+1-k)=hold_znw
3713          END DO
3714       END IF
3715
3716       DO k=1, kde-1
3717          grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
3718          grid%rdnw(k) = 1./grid%dnw(k)
3719          grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
3720       END DO
3721
3722       !  Now the same sort of computations with the half eta levels, even ANOTHER
3723       !  level less than the one above.
3724
3725       DO k=2, kde-1
3726          grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
3727          grid%rdn(k) = 1./grid%dn(k)
3728          grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
3729          grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
3730       END DO
3731
3732       !  Scads of vertical coefficients.
3733
3734       cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2)
3735       cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3)
3736
3737       grid%cf1  = grid%fnp(2) + cof1
3738       grid%cf2  = grid%fnm(2) - cof1 - cof2
3739       grid%cf3  = cof2
3740
3741       grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
3742       grid%cfn1 = -.5*grid%dnw(kde-1)/grid%dn(kde-1)
3743
3744       !  Inverse grid distances.
3745
3746       grid%rdx = 1./config_flags%dx
3747       grid%rdy = 1./config_flags%dy
3748
3749       !  Some of the many weird geopotential initializations that we'll see today: grid%ph0 is total,
3750       !  and grid%ph_2 is a perturbation from the base state geopotential.  We set the base geopotential
3751       !  at the lowest level to terrain elevation * gravity.
3752
3753       DO j=jts,jte
3754          DO i=its,ite
3755             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3756             grid%ph0(i,1,j) = grid%ht(i,j) * g
3757             grid%ph_2(i,1,j) = 0.
3758          END DO
3759       END DO
3760
3761       !  Base state potential temperature and inverse density (alpha = 1/rho) from
3762       !  the half eta levels and the base-profile surface pressure.  Compute 1/rho
3763       !  from equation of state.  The potential temperature is a perturbation from t0.
3764
3765       DO j = jts, MIN(jte,jde-1)
3766          DO i = its, MIN(ite,ide-1)
3767
3768             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3769
3770             !  Base state pressure is a function of eta level and terrain, only, plus
3771             !  the hand full of constants: p00 (sea level pressure, Pa), t00 (sea level
3772             !  temperature, K), and A (temperature difference, from 1000 mb to 300 mb, K).
3773
3774             p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 )
3775
3776
3777             DO k = 1, kte-1
3778                grid%php(i,k,j) = grid%c3f(k)*(p_surf - grid%p_top)+grid%c4f(k) + grid%p_top ! temporary, full lev base pressure
3779                grid%pb(i,k,j)  = grid%c3h(k)*(p_surf - grid%p_top)+grid%c4h(k) + grid%p_top
3780                temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) )
3781                IF ( grid%pb(i,k,j) .LT. p_strat ) THEN
3782                    temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat )
3783                ENDIF
3784 !              temp =             t00 + A*LOG(grid%pb(i,k,j)/p00)
3785                grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0
3786                grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm
3787             END DO
3788             grid%php(i,kte,j) = grid%p_top
3789             !  Base state mu is defined as base state surface pressure minus grid%p_top
3790             grid%MUB(i,j) = p_surf - grid%p_top
3791             !  Dry surface pressure is defined as the following (this mu is from the input file
3792             !  computed from the dry pressure).  Here the dry pressure is just reconstituted.
3793             pd_surf = grid%MU0(i,j) + grid%p_top
3794             !  Integrate base geopotential, starting at terrain elevation.  This assures that
3795             !  the base state is in exact hydrostatic balance with respect to the model equations.
3796             !  This field is on full levels.
3797             grid%phb(i,1,j) = grid%ht(i,j) * g
3798             IF (grid%hypsometric_opt == 1) THEN
3799                DO kk  = 2,kte
3800                   k = kk-1
3801                   grid%phb(i,kk,j) = grid%phb(i,kk-1,j) - grid%dnw(kk-1)*(grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))*grid%alb(i,kk-1,j)
3802                END DO
3803             ELSE IF (grid%hypsometric_opt == 2) THEN
3804                DO k = 2,kte
3805                   pfu = grid%c3f(k  )*grid%MUB(i,j)+grid%c4f(k  ) + grid%p_top
3806                   pfd = grid%c3f(k-1)*grid%MUB(i,j)+grid%c4f(k-1) + grid%p_top
3807                   phm = grid%c3h(k-1)*grid%MUB(i,j)+grid%c4h(k-1) + grid%p_top
3808                   grid%phb(i,k,j) = grid%phb(i,k-1,j) + grid%alb(i,k-1,j)*phm*LOG(pfd/pfu)
3809                END DO
3810             ELSE
3811                CALL wrf_error_fatal( 'initialize_real: hypsometric_opt should be 1 or 2' )
3812             END IF
3813
3814          END DO
3815       END DO
3816
3817 !+---+-----------------------------------------------------------------+
3818       ! New addition by Greg Thompson to dry out the stratosphere.
3819 !     CALL wrf_debug ( 0 , ' calling routine to dry stratosphere')
3820 !     CALL dry_stratos ( grid%t_2, moist(:,:,:,P_QV), grid%phb, &
3821 !                        ids , ide , jds , jde , kds , kde , &
3822 !                        ims , ime , jms , jme , kms , kme , &
3823 !                        its , ite , jts , jte , kts , kte )
3824 !+---+-----------------------------------------------------------------+
3825
3826       !  Fill in the outer rows and columns to allow us to be sloppy.
3827
3828       IF ( ite .EQ. ide ) THEN
3829       i = ide
3830       DO j = jts, MIN(jde-1,jte)
3831          grid%MUB(i,j) = grid%MUB(i-1,j)
3832          grid%MU_2(i,j) = grid%MU_2(i-1,j)
3833          DO k = 1, kte-1
3834             grid%pb(i,k,j) = grid%pb(i-1,k,j)
3835             grid%t_init(i,k,j) = grid%t_init(i-1,k,j)
3836             grid%alb(i,k,j) = grid%alb(i-1,k,j)
3837          END DO
3838          DO k = 1, kte
3839             grid%phb(i,k,j) = grid%phb(i-1,k,j)
3840          END DO
3841       END DO
3842       END IF
3843
3844       IF ( jte .EQ. jde ) THEN
3845       j = jde
3846       DO i = its, ite
3847          grid%MUB(i,j) = grid%MUB(i,j-1)
3848          grid%MU_2(i,j) = grid%MU_2(i,j-1)
3849          DO k = 1, kte-1
3850             grid%pb(i,k,j) = grid%pb(i,k,j-1)
3851             grid%t_init(i,k,j) = grid%t_init(i,k,j-1)
3852             grid%alb(i,k,j) = grid%alb(i,k,j-1)
3853          END DO
3854          DO k = 1, kte
3855             grid%phb(i,k,j) = grid%phb(i,k,j-1)
3856          END DO
3857       END DO
3858       END IF
3859
3860       !  Compute the total column perturbation dry pressure (grid%mub + grid%mu_2 + ptop = dry grid%psfc).
3861
3862       DO j = jts, min(jde-1,jte)
3863          DO i = its, min(ide-1,ite)
3864             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3865             grid%MU_2(i,j) = grid%MU0(i,j) - grid%MUB(i,j)
3866          END DO
3867       END DO
3868
3869       !  Fill in the outer rows and columns to allow us to be sloppy.
3870
3871       IF ( ite .EQ. ide ) THEN
3872       i = ide
3873       DO j = jts, MIN(jde-1,jte)
3874          grid%MU_2(i,j) = grid%MU_2(i-1,j)
3875       END DO
3876       END IF
3877
3878       IF ( jte .EQ. jde ) THEN
3879       j = jde
3880       DO i = its, ite
3881          grid%MU_2(i,j) = grid%MU_2(i,j-1)
3882       END DO
3883       END IF
3884
3885       lev500 = 0
3886       DO j = jts, min(jde-1,jte)
3887          DO i = its, min(ide-1,ite)
3888             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3889
3890             !  Assign the potential temperature (perturbation from t0) and qv on all the mass
3891             !  point locations.
3892
3893             DO k =  1 , kde-1
3894                grid%t_2(i,k,j)          = grid%t_2(i,k,j) - t0
3895             END DO
3896
3897             dpmu = 10001.
3898             loop_count = 0
3899
3900             DO WHILE ( ( ABS(dpmu) .GT. 10. ) .AND. &
3901                        ( loop_count .LT. 5 ) )
3902
3903                loop_count = loop_count + 1
3904
3905                !  Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum
3906                !  equation) down from the top to get the pressure perturbation.  First get the pressure
3907                !  perturbation, moisture, and inverse density (total and perturbation) at the top-most level.
3908
3909                kk = kte-1
3910                k = kk+1
3911
3912                qtot=0.
3913                DO im = PARAM_FIRST_SCALAR, num_3d_m
3914                  qtot = qtot + moist(i,kk,j,im)
3915                ENDDO
3916                qvf2 = 1./(1.+qtot)
3917                qvf1 = qtot*qvf2
3918
3919                grid%p(i,kk,j) = - 0.5*((grid%c1f(k)*grid%Mu_2(i,j))+qvf1*(grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)))/grid%rdnw(kk)/qvf2
3920                qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
3921                grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf&
3922                                  *(((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
3923                grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
3924                grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
3925
3926                !  Now, integrate down the column to compute the pressure perturbation, and diagnose the two
3927                !  inverse density fields (total and perturbation).
3928
3929                DO kk=kte-2,1,-1
3930                   k = kk + 1
3931                   qtot=0.
3932                   DO im = PARAM_FIRST_SCALAR, num_3d_m
3933                     qtot = qtot + 0.5*(moist(i,kk,j,im)+moist(i,kk+1,j,im))
3934                   ENDDO
3935                   qvf2 = 1./(1.+qtot)
3936                   qvf1 = qtot*qvf2
3937                   grid%p(i,kk,j) = grid%p(i,kk+1,j) - ((grid%c1f(k)*grid%Mu_2(i,j)) + qvf1*(grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)))/qvf2/grid%rdn(kk+1)
3938                   qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
3939                   grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* &
3940                               (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
3941                   grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
3942                   grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
3943                END DO
3944
3945 #if 1
3946                !  This is the hydrostatic equation used in the model after the small timesteps.  In
3947                !  the model, grid%al (inverse density) is computed from the geopotential.
3948
3949                IF (grid%hypsometric_opt == 1) THEN
3950                   DO kk  = 2,kte
3951                      k = kk - 1
3952                      grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - &
3953                                    grid%dnw(kk-1) * ( ((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mu_2(i,j)))*grid%al(i,kk-1,j) &
3954                                  + (grid%c1h(k)*grid%mu_2(i,j))*grid%alb(i,kk-1,j) )
3955                      grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j)
3956                   END DO
3957                ELSE IF (grid%hypsometric_opt == 2) THEN
3958                 ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure.
3959                 ! Note that al*p approximates Rd*T and dLOG(p) does z.
3960                 ! Here T varies mostly linear with z, the first-order integration produces better result.
3961
3962                   grid%ph_2(i,1,j) = grid%phb(i,1,j)
3963                   DO k = 2,kte
3964                      pfu = grid%c3f(k  )*grid%MU0(i,j)+grid%c4f(k  ) + grid%p_top
3965                      pfd = grid%c3f(k-1)*grid%MU0(i,j)+grid%c4f(k-1) + grid%p_top
3966                      phm = grid%c3h(k-1)*grid%MU0(i,j)+grid%c4h(k-1) + grid%p_top
3967                      grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu)
3968                   END DO
3969
3970                   DO k = 1,kte
3971                      grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j)
3972                   END DO
3973                END IF
3974 #else
3975                !  Get the perturbation geopotential from the 3d height array from WPS.
3976
3977                DO k  = 2,kte
3978                   grid%ph_2(i,k,j) = grid%ph0(i,k,j)*g - grid%phb(i,k,j)
3979                END DO
3980 #endif
3981
3982                !  Recompute density, simlar to what the model does.
3983
3984                IF (grid%hypsometric_opt == 1) THEN
3985                DO k=kts,kte-1
3986                   grid%al(i,k,j)=-1./((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mu_2(i,j)))*(grid%alb(i,k,j)*(grid%c1h(k)*grid%mu_2(i,j))  &
3987                                  +grid%rdnw(k)*(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)))
3988                ENDDO
3989                ELSE IF (grid%hypsometric_opt == 2) THEN
3990                DO k=kts,kte-1
3991                   pfu = grid%c3f(k+1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k+1)+grid%p_top
3992                   pfd = grid%c3f(k  )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k  )+grid%p_top
3993                   phm = grid%c3h(k  )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4h(k  )+grid%p_top
3994                   qvf=-1./((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mu_2(i,j)))*(grid%alb(i,k,j)*(grid%c1h(k)*grid%mu_2(i,j))  &
3995                                  +grid%rdnw(k)*(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)))
3996                   grid%al(i,k,j) = (grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)+grid%phb(i,k+1,j)-grid%phb(i,k,j)) &
3997                                     /phm/LOG(pfd/pfu)-grid%alb(i,k,j)
3998 #if 0
3999 if ( internal_time_loop .EQ. 1 ) THEN
4000 if (i.eq.its .and. j.eq.its)then
4001 if (k.eq.kts)then
4002 print *,'                             k        old al          new al             alb            new alt           dz (m)        pres up          Pres mid        Pres down           c3 k           c3 k+1             c4 k            c4 k+1'
4003 print *,' ======================================================================================================================================================================================================================================='
4004 endif
4005 print *,'                  ',k,qvf,grid%al(i,k,j),grid%alb(i,k,j),grid%al(i,k,j)+grid%alb(i,k,j),(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)+grid%phb(i,k+1,j)-grid%phb(i,k,j)),pfu,phm,pfd,grid%c3f(k),grid%c3f(k+1),grid%c4f(k),grid%c4f(k+1)
4006 endif
4007 endif
4008 #endif
4009
4010                ENDDO
4011                END IF
4012
4013                !  Compute pressure similarly to how computed within model.
4014
4015                DO k=kts,kte-1
4016                   qvf = 1.+rvovrd*moist(i,k,j,P_QV)
4017                   grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/                     &
4018                                (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv  &
4019                                -grid%pb(i,k,j)
4020                   grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
4021                   grid%alt(i,k,j) = grid%al(i,k,j) + grid%alb(i,k,j)
4022                ENDDO
4023
4024                !  Adjust the column pressure so that the computed 500 mb height is close to the
4025                !  input value (of course, not when we are doing hybrid input).
4026
4027                IF ( ( flag_metgrid .EQ. 1 ) .AND. ( i .EQ. i_valid ) .AND. ( j .EQ. j_valid ) ) THEN
4028                   DO k = 1 , num_metgrid_levels
4029                      IF ( ABS ( grid%p_gc(i,k,j) - 50000. ) .LT. 1. ) THEN
4030                         lev500 = k
4031                         EXIT
4032                      END IF
4033                   END DO
4034                END IF
4035
4036                !  We only do the adjustment of height if we have the input data on pressure
4037                !  surfaces, and folks have asked to do this option.
4038
4039                IF ( ( flag_metgrid .EQ. 1 ) .AND. &
4040                     ( flag_ptheta  .EQ. 0 ) .AND. &
4041                     ( config_flags%adjust_heights ) .AND. &
4042                     ( lev500 .NE. 0 ) ) THEN
4043
4044                   DO k = 2 , kte-1
4045
4046                      !  Get the pressures on the full eta levels (grid%php is defined above as
4047                      !  the full-lev base pressure, an easy array to use for 3d space).
4048
4049                      pl = grid%php(i,k  ,j) + &
4050                           ( grid%p(i,k-1  ,j) * ( grid%znw(k    ) - grid%znu(k  ) ) + &
4051                             grid%p(i,k    ,j) * ( grid%znu(k-1  ) - grid%znw(k  ) ) ) / &
4052                           ( grid%znu(k-1  ) - grid%znu(k  ) )
4053                      pu = grid%php(i,k+1,j) + &
4054                           ( grid%p(i,k-1+1,j) * ( grid%znw(k  +1) - grid%znu(k+1) ) + &
4055                             grid%p(i,k  +1,j) * ( grid%znu(k-1+1) - grid%znw(k+1) ) ) / &
4056                           ( grid%znu(k-1+1) - grid%znu(k+1) )
4057
4058                      !  If these pressure levels trap 500 mb, use them to interpolate
4059                      !  to the 500 mb level of the computed height.
4060
4061                      IF ( ( pl .GE. 50000. ) .AND. ( pu .LT. 50000. ) ) THEN
4062                         zl = ( grid%ph_2(i,k  ,j) + grid%phb(i,k  ,j) ) / g
4063                         zu = ( grid%ph_2(i,k+1,j) + grid%phb(i,k+1,j) ) / g
4064
4065                         z500 = ( zl * ( LOG(50000.) - LOG(pu    ) ) + &
4066                                  zu * ( LOG(pl    ) - LOG(50000.) ) ) / &
4067                                ( LOG(pl) - LOG(pu) )
4068 !                       z500 = ( zl * (    (50000.) -    (pu    ) ) + &
4069 !                                zu * (    (pl    ) -    (50000.) ) ) / &
4070 !                              (    (pl) -    (pu) )
4071
4072                         !  Compute the difference of the 500 mb heights (computed minus input), and
4073                         !  then the change in grid%mu_2.  The grid%php is still full-levels, base pressure.
4074
4075                         dz500 = z500 - grid%ght_gc(i,lev500,j)
4076                         tvsfc = ((grid%t_2(i,1,j)+t0)*((grid%p(i,1,j)+grid%php(i,1,j))/p1000mb)**(r_d/cp)) * &
4077                                 (1.+0.6*moist(i,1,j,P_QV))
4078                         dpmu = ( grid%php(i,1,j) + grid%p(i,1,j) ) * EXP ( g * dz500 / ( r_d * tvsfc ) )
4079                         dpmu = dpmu - ( grid%php(i,1,j) + grid%p(i,1,j) )
4080                         grid%MU_2(i,j) = grid%MU_2(i,j) - dpmu
4081                         EXIT
4082                      END IF
4083
4084                   END DO
4085                ELSE
4086                   dpmu = 0.
4087                END IF
4088
4089             END DO
4090
4091          END DO
4092       END DO
4093
4094       !  Now we have full pressure on eta levels, get final computation of Qv.
4095       !  The use of u_1 (rh) and v_1 (temperature) is temporary.
4096
4097       grid%v_1 = grid%t_2+t0
4098
4099       CALL theta_to_t ( grid%v_1 , grid%p_hyd  , p00 , &
4100                         ids , ide , jds , jde , kds , kde , &
4101                         ims , ime , jms , jme , kms , kme , &
4102                         its , ite , jts , jte , kts , kte )
4103
4104       IF      ( .not.config_flags%use_sh_qv ) THEN
4105       IF      ( config_flags%rh2qv_method .eq. 1 ) THEN
4106          CALL rh_to_mxrat1(grid%u_1, grid%v_1, grid%p_hyd , moist(:,:,:,P_QV) ,       &
4107                            config_flags%rh2qv_wrt_liquid ,                        &
4108                            config_flags%qv_max_p_safe ,                           &
4109                            config_flags%qv_max_flag , config_flags%qv_max_value , &
4110                            config_flags%qv_min_p_safe ,                           &
4111                            config_flags%qv_min_flag , config_flags%qv_min_value , &
4112                            ids , ide , jds , jde , kds , kde ,                    &
4113                            ims , ime , jms , jme , kms , kme ,                    &
4114                            its , ite , jts , jte , kts , kte-1 )
4115       ELSE IF ( config_flags%rh2qv_method .eq. 2 ) THEN
4116          CALL rh_to_mxrat2(grid%u_1, grid%v_1, grid%p_hyd , moist(:,:,:,P_QV) ,       &
4117                            config_flags%rh2qv_wrt_liquid ,                        &
4118                            config_flags%qv_max_p_safe ,                           &
4119                            config_flags%qv_max_flag , config_flags%qv_max_value , &
4120                            config_flags%qv_min_p_safe ,                           &
4121                            config_flags%qv_min_flag , config_flags%qv_min_value , &
4122                            ids , ide , jds , jde , kds , kde ,                    &
4123                            ims , ime , jms , jme , kms , kme ,                    &
4124                            its , ite , jts , jte , kts , kte-1 )
4125       END IF
4126       END IF
4127
4128       !  Compute pressure similarly to how computed within model, with final Qv.
4129
4130       !  Do a re-balance or not?  0 = NOPE
4131       !  Note that rebalance must be 1 for vertical nesting
4132       IF ( config_flags%rebalance .EQ. 0 ) THEN
4133
4134           DO j = jts, min(jde-1,jte)
4135              DO k=kts,kte-1
4136                 DO i = its, min(ide,ite)
4137                    qvf = 1.+rvovrd*moist(i,k,j,P_QV)
4138                    grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/                     &
4139                                 (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv  &
4140                                 -grid%pb(i,k,j)
4141                    grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
4142                 ENDDO
4143              ENDDO
4144           ENDDO
4145
4146       ELSE ! rebalance
4147
4148          lev500 = 0
4149          DO j = jts, min(jde-1,jte)
4150             DO i = its, min(ide-1,ite)
4151                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4152
4153                dpmu = 10001.
4154                loop_count = 0
4155
4156                DO WHILE ( ( ABS(dpmu) .GT. 10. ) .AND. &
4157                           ( loop_count .LT. 5 ) )
4158
4159                   loop_count = loop_count + 1
4160
4161                   !  Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum
4162                   !  equation) down from the top to get the pressure perturbation.  First get the pressure
4163                   !  perturbation, moisture, and inverse density (total and perturbation) at the top-most level.
4164
4165                   kk = kte-1
4166                   k=kk+1
4167
4168                   qtot=0.
4169                   DO im = PARAM_FIRST_SCALAR, num_3d_m
4170                     qtot = qtot + moist(i,kk,j,im)
4171                   ENDDO
4172                   qvf2 = 1./(1.+qtot)
4173                   qvf1 = qtot*qvf2
4174
4175                   grid%p(i,kk,j) = - 0.5*((grid%c1f(k)*grid%Mu_2(i,j))+qvf1*(grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)))/grid%rdnw(kk)/qvf2
4176                   qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
4177                   grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf&
4178                                     *(((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
4179                   grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
4180                   grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
4181
4182                   !  Now, integrate down the column to compute the pressure perturbation, and diagnose the two
4183                   !  inverse density fields (total and perturbation).
4184
4185                   DO kk=kte-2,1,-1
4186                      k = kk + 1
4187                      qtot=0.
4188                      DO im = PARAM_FIRST_SCALAR, num_3d_m
4189                        qtot = qtot + 0.5*(moist(i,kk,j,im)+moist(i,kk+1,j,im))
4190                      ENDDO
4191                      qvf2 = 1./(1.+qtot)
4192                      qvf1 = qtot*qvf2
4193                      grid%p(i,kk,j) = grid%p(i,kk+1,j) - ((grid%c1f(k)*grid%Mu_2(i,j)) + qvf1*(grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)))/qvf2/grid%rdn(kk+1)
4194                      qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
4195                      grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* &
4196                                  (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
4197                      grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
4198                      grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
4199                   END DO
4200
4201 #if 1
4202                   !  This is the hydrostatic equation used in the model after the small timesteps.  In
4203                   !  the model, grid%al (inverse density) is computed from the geopotential.
4204
4205                   IF (grid%hypsometric_opt == 1) THEN
4206
4207                      DO kk  = 2,kte
4208                         k = kk-1
4209                         grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - &
4210                                       grid%dnw(kk-1) * ( ((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mu_2(i,j)))*grid%al(i,kk-1,j) &
4211                                     + (grid%c1h(k)*grid%mu_2(i,j))*grid%alb(i,kk-1,j) )
4212                         grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j)
4213                      END DO
4214
4215                   ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure.
4216                   ! Note that al*p approximates Rd*T and dLOG(p) does z.
4217                   ! Here T varies mostly linear with z, the first-order integration produces better result.
4218
4219                   ELSE IF (grid%hypsometric_opt == 2) THEN
4220
4221                      grid%ph_2(i,1,j) = grid%phb(i,1,j)
4222                      DO k = 2,kte
4223                         pfu = grid%c3f(k  )*grid%MU0(i,j)+grid%c4f(k  ) + grid%p_top
4224                         pfd = grid%c3f(k-1)*grid%MU0(i,j)+grid%c4f(k-1) + grid%p_top
4225                         phm = grid%c3h(k-1)*grid%MU0(i,j)+grid%c4h(k-1) + grid%p_top
4226                         grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu)
4227                      END DO
4228
4229                      DO k = 1,kte
4230                         grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j)
4231                      END DO
4232                   END IF
4233 #else
4234                   !  Get the perturbation geopotential from the 3d height array from WPS.
4235
4236                   DO k  = 2,kte
4237                      grid%ph_2(i,k,j) = grid%ph0(i,k,j)*g - grid%phb(i,k,j)
4238                   END DO
4239 #endif
4240
4241                   !  Recompute density, simlar to what the model does.
4242
4243                   IF (grid%hypsometric_opt == 1) THEN
4244                      DO k=kts,kte-1
4245                         grid%al(i,k,j)=-1./((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mu_2(i,j)))*(grid%alb(i,k,j)*(grid%c1h(k)*grid%mu_2(i,j))  &
4246                                        +grid%rdnw(k)*(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)))
4247                      ENDDO
4248                   ELSE IF (grid%hypsometric_opt == 2) THEN
4249                      DO k=kts,kte-1
4250                         pfu = grid%c3f(k+1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k+1)+grid%p_top
4251                         pfd = grid%c3f(k  )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k  )+grid%p_top
4252                         phm = grid%c3h(k  )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4h(k  )+grid%p_top
4253                         grid%al(i,k,j) = (grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)+grid%phb(i,k+1,j)-grid%phb(i,k,j)) &
4254                                           /phm/LOG(pfd/pfu)-grid%alb(i,k,j)
4255                      ENDDO
4256                   END IF
4257
4258                   !  Compute pressure similarly to how computed within model.
4259
4260                   DO k=kts,kte-1
4261                      qvf = 1.+rvovrd*moist(i,k,j,P_QV)
4262                      grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/                     &
4263                                   (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv  &
4264                                   -grid%pb(i,k,j)
4265                      grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
4266                      grid%alt(i,k,j) = grid%al(i,k,j) + grid%alb(i,k,j)
4267                   ENDDO
4268
4269                   !  Adjust the column pressure so that the computed 500 mb height is close to the
4270                   !  input value (of course, not when we are doing hybrid input).
4271
4272                   IF ( ( flag_metgrid .EQ. 1 ) .AND. ( i .EQ. i_valid ) .AND. ( j .EQ. j_valid ) ) THEN
4273                      DO k = 1 , num_metgrid_levels
4274                         IF ( ABS ( grid%p_gc(i,k,j) - 50000. ) .LT. 1. ) THEN
4275                            lev500 = k
4276                            EXIT
4277                         END IF
4278                      END DO
4279                   END IF
4280
4281                   !  We only do the adjustment of height if we have the input data on pressure
4282                   !  surfaces, and folks have asked to do this option.
4283
4284                   IF ( ( flag_metgrid .EQ. 1 ) .AND. &
4285                        ( flag_ptheta  .EQ. 0 ) .AND. &
4286                        ( config_flags%adjust_heights ) .AND. &
4287                        ( lev500 .NE. 0 ) ) THEN
4288
4289                      DO k = 2 , kte-1
4290
4291                         !  Get the pressures on the full eta levels (grid%php is defined above as
4292                         !  the full-lev base pressure, an easy array to use for 3d space).
4293
4294                         pl = grid%php(i,k  ,j) + &
4295                              ( grid%p(i,k-1  ,j) * ( grid%znw(k    ) - grid%znu(k  ) ) + &
4296                                grid%p(i,k    ,j) * ( grid%znu(k-1  ) - grid%znw(k  ) ) ) / &
4297                              ( grid%znu(k-1  ) - grid%znu(k  ) )
4298                         pu = grid%php(i,k+1,j) + &
4299                              ( grid%p(i,k-1+1,j) * ( grid%znw(k  +1) - grid%znu(k+1) ) + &
4300                                grid%p(i,k  +1,j) * ( grid%znu(k-1+1) - grid%znw(k+1) ) ) / &
4301                              ( grid%znu(k-1+1) - grid%znu(k+1) )
4302
4303                         !  If these pressure levels trap 500 mb, use them to interpolate
4304                         !  to the 500 mb level of the computed height.
4305
4306                         IF ( ( pl .GE. 50000. ) .AND. ( pu .LT. 50000. ) ) THEN
4307                            zl = ( grid%ph_2(i,k  ,j) + grid%phb(i,k  ,j) ) / g
4308                            zu = ( grid%ph_2(i,k+1,j) + grid%phb(i,k+1,j) ) / g
4309
4310                            z500 = ( zl * ( LOG(50000.) - LOG(pu    ) ) + &
4311                                     zu * ( LOG(pl    ) - LOG(50000.) ) ) / &
4312                                   ( LOG(pl) - LOG(pu) )
4313
4314                            !  Compute the difference of the 500 mb heights (computed minus input), and
4315                            !  then the change in grid%mu_2.  The grid%php is still full-levels, base pressure.
4316
4317                            dz500 = z500 - grid%ght_gc(i,lev500,j)
4318                            tvsfc = ((grid%t_2(i,1,j)+t0)*((grid%p(i,1,j)+grid%php(i,1,j))/p1000mb)**(r_d/cp)) * &
4319                                    (1.+0.6*moist(i,1,j,P_QV))
4320                            dpmu = ( grid%php(i,1,j) + grid%p(i,1,j) ) * EXP ( g * dz500 / ( r_d * tvsfc ) )
4321                            dpmu = dpmu - ( grid%php(i,1,j) + grid%p(i,1,j) )
4322                            grid%MU_2(i,j) = grid%MU_2(i,j) - dpmu
4323                            EXIT
4324                         END IF
4325
4326                      END DO
4327                   ELSE
4328                      dpmu = 0.
4329                   END IF
4330
4331                END DO
4332
4333             ENDDO
4334          ENDDO
4335       END IF ! rebalance
4336
4337       !  If this is data from the SI, then we probably do not have the original
4338       !  surface data laying around.  Note that these are all the lowest levels
4339       !  of the respective 3d arrays.  For surface pressure, we assume that the
4340       !  vertical gradient of grid%p prime is zilch.  This is not all that important.
4341       !  These are filled in so that the various plotting routines have something
4342       !  to play with at the initial time for the model.
4343
4344       IF ( flag_metgrid .NE. 1 ) THEN
4345          DO j = jts, min(jde-1,jte)
4346             DO i = its, min(ide,ite)
4347                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4348                grid%u10(i,j)=grid%u_2(i,1,j)
4349             END DO
4350          END DO
4351
4352          DO j = jts, min(jde,jte)
4353             DO i = its, min(ide-1,ite)
4354                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4355                grid%v10(i,j)=grid%v_2(i,1,j)
4356             END DO
4357          END DO
4358
4359          DO j = jts, min(jde-1,jte)
4360             DO i = its, min(ide-1,ite)
4361                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4362                p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 )
4363                grid%psfc(i,j)=p_surf + grid%p(i,1,j)
4364                grid%q2(i,j)=moist(i,1,j,P_QV)
4365                grid%th2(i,j)=grid%t_2(i,1,j)+300.
4366                grid%t2(i,j)=grid%th2(i,j)*(((grid%p(i,1,j)+grid%pb(i,1,j))/p00)**(r_d/cp))
4367             END DO
4368          END DO
4369
4370       !  If this data is from WPS, then we have previously assigned the surface
4371       !  data for u, v, and t.  If we have an input qv, welp, we assigned that one,
4372       !  too.  Now we pick up the left overs, and if RH came in - we assign the
4373       !  mixing ratio.
4374
4375       ELSE IF ( flag_metgrid .EQ. 1 ) THEN
4376
4377          DO j = jts, min(jde-1,jte)
4378             DO i = its, min(ide-1,ite)
4379                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4380 !              p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 )
4381 !              grid%psfc(i,j)=p_surf + grid%p(i,1,j)
4382                grid%th2(i,j)=grid%t2(i,j)*(p00/(grid%p(i,1,j)+grid%pb(i,1,j)))**(r_d/cp)
4383             END DO
4384          END DO
4385          IF ( flag_qv .NE. 1 ) THEN
4386             DO j = jts, min(jde-1,jte)
4387                DO i = its, min(ide-1,ite)
4388                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4389 !                 grid%q2(i,j)=moist(i,1,j,P_QV)
4390                   grid%q2(i,j)=grid%qv_gc(i,1,j)
4391                END DO
4392             END DO
4393          END IF
4394
4395       END IF
4396       CALL cpu_time(t_end)
4397
4398 !  Set flag to denote that we are saving original values of HT, MUB, and
4399 !  PHB for 2-way nesting and cycling.
4400
4401       grid%save_topo_from_real=1
4402
4403       !  Template for initializing tracer arrays.
4404       !  Right now, a small plane in the middle of the domain at lowest model level is
4405       !  defined.
4406
4407       IF (config_flags%tracer_opt .eq. 2) THEN
4408           DO j = (jde + jds)/2 - 4, (jde + jds)/2 + 4, 1
4409             DO i = (ide + ids)/2 - 4, (ide + ids)/2 + 4, 1
4410                IF ( its .LE. i .and. ite .GE. i .and. jts .LE. j .and. jte .GE. j ) THEN
4411                  tracer(i, 1, j, P_tr17_1) = 1.
4412                  tracer(i, 1, j, P_tr17_2) = 1.
4413                  tracer(i, 1, j, P_tr17_3) = 1.
4414                  tracer(i, 1, j, P_tr17_4) = 1.
4415 !                tracer(i, 1, j, P_tr17_5) = 1.
4416 !                tracer(i, 1, j, P_tr17_6) = 1.
4417 !                tracer(i, 1, j, P_tr17_7) = 1.
4418 !                tracer(i, 1, j, P_tr17_8) = 1.
4419                END IF
4420             END DO
4421           END DO
4422       END IF
4423
4424       !  Simple initialization for 3d ocean.
4425
4426       IF ( config_flags%sf_ocean_physics .EQ. PWP3DSCHEME ) THEN
4427
4428          !  From a profile of user defined temps, depths, and salinity - we
4429          !  construct a 3d ocean.  Because this is a 1d profile, domains that
4430          !  have varied ocean characteristics that deviate should significantly from
4431          !  the provided initial state will probably give poor results.
4432
4433          DO k = 1,model_config_rec%ocean_levels
4434             grid%om_depth(:,k,:) = model_config_rec%ocean_z(k)
4435             grid%om_tmp  (:,k,:) = model_config_rec%ocean_t(k)
4436             grid%om_s    (:,k,:) = model_config_rec%ocean_s(k)
4437             grid%om_tini (:,k,:) = model_config_rec%ocean_t(k)
4438             grid%om_sini (:,k,:) = model_config_rec%ocean_s(k)
4439             grid%om_u    (:,k,:) = 0.
4440             grid%om_v    (:,k,:) = 0.
4441          END DO
4442
4443          !  Apparently, the mixed layer is 5 m.
4444
4445          grid%om_ml = 5
4446
4447          !  Keep lat, lon info for the ocean model.
4448
4449          grid%om_lon = grid%xlong
4450          grid%om_lat = grid%xlat
4451
4452          !  If we have access to a non-horizontally isotropic SST, let's
4453          !  use that as a better starting point for the ocean temp.  Note that
4454          !  we assume if this is an ice point that implies this is a land point
4455          !  for WRF.  If it is a land point, then we do not have any ocean underneath.
4456
4457          IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN
4458             DO j = jts, min(jde-1,jte)
4459                DO k = 1,model_config_rec%ocean_levels
4460                   DO i = its, min(ide-1,ite)
4461                      grid%om_tmp(i,k,j) = grid%sst(i,j) - ( grid%om_tini(i,1,j) - grid%om_tini(i,k,j) )
4462                   END DO
4463                END DO
4464             END DO
4465
4466             DO j = jts, min(jde-1,jte)
4467                DO k = 1,model_config_rec%ocean_levels
4468                   DO i = its, min(ide-1,ite)
4469                      grid%om_tini(i,k,j) = grid%om_tmp(i,k,j)
4470                   END DO
4471                END DO
4472             END DO
4473          END IF
4474
4475       END IF
4476
4477       ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte
4478
4479 !+---+-----------------------------------------------------------------+
4480 !..Scale the lowest level aerosol data into an emissions rate.  This is
4481 !.. very far from ideal, but need higher emissions where larger amount
4482 !.. of (climo) existing and lesser emissions where there exists fewer to
4483 !.. begin as a first-order simplistic approach.  Later, proper connection to
4484 !.. emission inventory would be better, but, for now, scale like this:
4485 !.. where: Nwfa=50 per cc, emit 0.875E4 aerosols per second per grid box unit
4486 !..        that was tested as ~(20kmx20kmx50m = 2.E10 m**-3)
4487 !..
4488 !..Add option for aerosol emissions from first guess source (e.g., GEOS-5)
4489 !.. Can process aerosol from anthropogenic as well as biomass burning sources
4490 !.. The flag_qn***2d variables in the met_em files must be set to 1
4491 !.. for anthropogenic aerosol emissions to activate
4492 !.. The flag_qn**bba2d variables in the met_em files must be set to 1
4493 !.. to read biomass burning aerosol emissions
4494 !+---+-----------------------------------------------------------------+
4495
4496       if_thompsonaero_2d: IF (config_flags%mp_physics .EQ. THOMPSONAERO .AND. &
4497                 config_flags%wif_input_opt .GT. 0) THEN
4498
4499       select_aer_init_opt_2d: select case (aer_init_opt)
4500
4501                case (0)  ! Initialize to zero
4502
4503                   CALL wrf_debug (0 , 'COMMENT: Surface emissions of QNWFA will be computed in microphysics')
4504                   CALL wrf_debug (0 , 'COMMENT: Surface emissions of QNIFA will be initialized to zero values')
4505                   do j = jts, MIN(jde-1,jte)
4506                   do i = its, MIN(ide-1,ite)
4507                      grid%qnwfa2d(i,j) = 0.0
4508                      grid%qnifa2d(i,j) = 0.0
4509                   enddo
4510                   enddo
4511
4512                case (1)  ! Monthly climatology (GOCART, etc.)
4513
4514                      ! Water-friendly aerosol
4515                   CALL wrf_debug (0 , 'Calculating anthropogenic surface emissions of QNWFA using climatology')
4516                   do j = jts, min(jde-1,jte)
4517                   do i = its, min(ide-1,ite)
4518                      z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4519                      grid%qnwfa2d(i,j) = grid%w_wif_now(i,1,j) * 0.000196 * (50./z1)
4520                   enddo
4521                   enddo
4522
4523                      ! Ice-friendly aerosol
4524                   CALL wrf_debug (0 , 'Setting surface emissions of QNIFA to zero')
4525                   do j = jts, min(jde-1,jte)
4526                   do i = its, min(ide-1,ite)
4527                      grid%qnifa2d(i,j) = 0.0
4528                   enddo
4529                   enddo
4530
4531                     ! Black carbon aerosol
4532                   if (config_flags%wif_input_opt .EQ. 2) then
4533                      CALL wrf_debug (0 , 'Calculating anthropogenic surface emissions of QNBCA using climatology')
4534                      do j = jts, min(jde-1,jte)
4535                      do i = its, min(ide-1,ite)
4536                         z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4537                         grid%qnbca2d(i,j) = grid%b_wif_now(i,1,j) * 0.000098 * (50./z1) * (1. + grid%frc_urb2d(i,j))
4538                      enddo
4539                      enddo
4540                   end if
4541
4542                case (2)  ! First guess aerosol (GEOS-5, etc.)
4543
4544                      ! Water-friendly aerosol
4545                   if (flag_qnwfa2d .EQ. 1) then
4546                      CALL wrf_debug (0 , 'Calculating anthropogenic surface emissions of QNWFA using first guess')
4547                      do j = jts, min(jde-1,jte)
4548                      do i = its, min(ide-1,ite)
4549                         z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4550                         grid%qnwfa2d(i,j) = grid%qnwfa2d(i,j) * grid%alt(i,1,j) / z1
4551                      enddo
4552                      enddo
4553                   else
4554                      CALL wrf_debug (0 , 'Using first guess aerosol option, but no anthropogenic surface emissions of QNWFA found')
4555                      CALL wrf_debug (0 , 'Setting anthropogenic surface emissions of QNWFA to zero')
4556                      do j = jts, min(jde-1,jte)
4557                      do i = its, min(ide-1,ite)
4558                         grid%qnwfa2d(i,j) = 0.0
4559                      enddo
4560                      enddo
4561                   end if
4562
4563                      ! Ice-friendly aerosol
4564                   if (flag_qnifa2d .EQ. 1) then
4565                      CALL wrf_debug (0 , 'Calculating surface emissions of QNIFA using first guess')
4566                      do j = jts, min(jde-1,jte)
4567                      do i = its, min(ide-1,ite)
4568                         z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4569                         grid%qnifa2d(i,j) = grid%qnifa2d(i,j) * grid%alt(i,1,j) / z1
4570                      enddo
4571                      enddo
4572                   else
4573                      CALL wrf_debug (0 , 'Using first guess aerosol option, but no surface emissions of QNIFA found')
4574                      CALL wrf_debug (0 , 'Setting surface emissions of QNIFA to zero')
4575                      do j = jts, min(jde-1,jte)
4576                      do i = its, min(ide-1,ite)
4577                         grid%qnifa2d(i,j) = 0.0
4578                      enddo
4579                      enddo
4580                   end if
4581
4582                     ! Black carbon aerosol
4583                   if (config_flags%wif_input_opt .EQ. 2) then
4584                      if (flag_qnbca2d .EQ. 1) then
4585                         CALL wrf_debug (0 , 'Calculating surface emissions of QNBCA using first guess')
4586                         do j = jts, min(jde-1,jte)
4587                         do i = its, min(ide-1,ite)
4588                            z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4589                            grid%qnbca2d(i,j) = grid%qnbca2d(i,j) * grid%alt(i,1,j) / z1
4590                         enddo
4591                         enddo
4592                      else
4593                         CALL wrf_debug (0 , 'Using first guess aerosol option, but no surface emissions of QNBCA found')
4594                         CALL wrf_debug (0 , 'Setting surface emissions of QNBCA to zero')
4595                         do j = jts, min(jde-1,jte)
4596                         do i = its, min(ide-1,ite)
4597                            grid%qnbca2d(i,j) = 0.0
4598                         enddo
4599                         enddo
4600                      end if
4601                   end if
4602
4603                     ! Biomass burning aerosol
4604                   if (config_flags%aer_fire_emit_opt .GT. 0) then
4605                        ! Organic carbon first
4606                      if (flag_qnocbb2d .EQ. 1) then
4607                         CALL wrf_debug (0 , 'Calculating biomass burning surface emissions of organic carbon aerosol using first guess')
4608                         do j = jts, min(jde-1,jte)
4609                         do i = its, min(ide-1,ite)
4610                            z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4611                            grid%qnocbb2d(i,j) = grid%qnocbb2d(i,j) * grid%alt(i,1,j) / z1
4612                         enddo
4613                         enddo
4614                      else
4615                         CALL wrf_debug (0 , 'Using first guess aerosol option, but no biomass burning surface emissions of organic carbon aerosol found')
4616                         CALL wrf_debug (0 , 'Setting biomass burning surface emissions of organic carbon aerosol to zero')
4617                         do j = jts, min(jde-1,jte)
4618                         do i = its, min(ide-1,ite)
4619                            grid%qnocbb2d(i,j) = 0.0
4620                         enddo
4621                         enddo
4622                      end if
4623
4624                        ! Black carbon second
4625                      if (config_flags%aer_fire_emit_opt .EQ. 2) then
4626                         if (flag_qnbcbb2d .EQ. 1) then
4627                            CALL wrf_debug (0 , 'Calculating biomass burning surface emissions of black carbon aerosol using first guess')
4628                            do j = jts, min(jde-1,jte)
4629                            do i = its, min(ide-1,ite)
4630                               z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4631                               grid%qnbcbb2d(i,j) = grid%qnbcbb2d(i,j) * grid%alt(i,1,j) / z1
4632                            enddo
4633                            enddo
4634                         else
4635                            CALL wrf_debug (0 , 'Using first guess aerosol option, but no biomass burning surface emissions of black carbon aerosol found')
4636                            CALL wrf_debug (0 , 'Setting biomass burning surface emissions of black carbon aerosol to zero')
4637                            do j = jts, min(jde-1,jte)
4638                            do i = its, min(ide-1,ite)
4639                               grid%qnbcbb2d(i,j) = 0.0
4640                            enddo
4641                            enddo
4642                         end if
4643                      end if
4644                   else
4645                      CALL wrf_debug (0 , 'Skipping biomass burning surface emissions')
4646                   end if
4647
4648                case default
4649
4650                   CALL wrf_debug (0 , 'aer_init_opt = ', aer_init_opt)
4651                   CALL wrf_error_fatal ('Aerosol forcing option does not exist for mp_physics=28' )
4652
4653                end select select_aer_init_opt_2d
4654
4655       ENDIF if_thompsonaero_2d
4656
4657 !+---+-----------------------------------------------------------------+
4658 !..We can consider that in circumstance of a 'cold start' we can make
4659 !.. an attempt to insert some initial clouds to get a better starting
4660 !.. radiation representation due to clouds using the icloud3 cloud fraction
4661 !.. scheme.
4662 !+---+-----------------------------------------------------------------+
4663
4664       if (config_flags%insert_init_cloud .AND.                          &
4665                     (P_QC .gt. PARAM_FIRST_SCALAR .AND.                 &
4666                      P_QI .gt. PARAM_FIRST_SCALAR)) then
4667
4668          ALLOCATE(temp_P(kts:kte-1))
4669          ALLOCATE(temp_Dz(kts:kte-1))
4670          ALLOCATE(temp_T(kts:kte-1))
4671          ALLOCATE(temp_R(kts:kte-1))
4672          ALLOCATE(temp_Qv(kts:kte-1))
4673          ALLOCATE(temp_Qc(kts:kte-1))
4674          ALLOCATE(temp_Nc(kts:kte-1))
4675          ALLOCATE(temp_Qi(kts:kte-1))
4676          ALLOCATE(temp_Ni(kts:kte-1))
4677          ALLOCATE(temp_Qs(kts:kte-1))
4678          ALLOCATE(temp_CF(kts:kte-1))
4679
4680          i_end = MIN(ite,ide-1)
4681          j_end = MIN(jte,jde-1)
4682          max_relh = 1.5
4683 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
4684          max_relh = wrf_dm_max_real ( MAXVAL(grid%u_1(its:i_end,:,jts:j_end)) )
4685 #else
4686          max_relh = MAXVAL ( grid%u_1(its:i_end,:,jts:j_end) )
4687 #endif
4688          max_relh = max_relh*0.01
4689
4690          gridkm = SQRT(config_flags%dx*config_flags%dy)*0.001
4691
4692          !..As it occurs up above, temporarily utilizing the v_1 variable,
4693          !.. to hold temperature, which it does when time_loop=0.
4694
4695          IF ( internal_time_loop .GT. 1 ) THEN
4696             grid%v_1 = grid%t_2+t0
4697             CALL theta_to_t ( grid%v_1 , grid%p_hyd  , p00 , &
4698                               ids , ide , jds , jde , kds , kde , &
4699                               ims , ime , jms , jme , kms , kme , &
4700                               its , ite , jts , jte , kts , kte )
4701          ENDIF
4702
4703          do j = jts, j_end
4704          do i = its, i_end
4705             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4706             debug_flag = .false.
4707 !           if (i.eq.9 .and. j.eq.9) debug_flag = .true.
4708
4709             temp_xland = grid%xland(i,j)
4710             if (grid%lakemask(i,j) .eq. 1) temp_xland = 1
4711             do k = kts, kte-1
4712                temp_Dz(k) = (grid%ph_2(i,k+1,j)+grid%phb(i,k+1,j) - (grid%ph_2(i,k,j)+grid%phb(i,k,j)))/g
4713                temp_P(k) = grid%p_hyd(i,k,j)
4714                temp_T(k) = grid%v_1(i,k,j)         ! Around line num 1800 v_1 used to hold temperature.
4715                temp_R(k) = 1./grid%alt(i,k,j)
4716                temp_Qv(k) = moist(i,k,j,P_QV)
4717                temp_Qc(k) = MAX(0., moist(i,k,j,P_QC))
4718                temp_Qi(k) = MAX(0., moist(i,k,j,P_QI))
4719                if (P_QS .gt. 1) then
4720                   temp_Qs(k) = MAX(0., moist(i,k,j,P_QS))
4721                else
4722                   temp_Qs(k) = 0.
4723                endif
4724                if (P_QNI .gt. 1) then
4725                   temp_Ni(k) = MAX(0., scalar(i,k,j,P_QNI))
4726                else
4727                   temp_Ni(k) = 0.
4728                endif
4729                if (P_QNC .gt. 1) then
4730                   temp_Nc(k) = MAX(0., scalar(i,k,j,P_QNC))
4731                else
4732                   temp_Nc(k) = 0.
4733                endif
4734                temp_CF(k) = 0.
4735             enddo
4736
4737             call cal_cldfra3(temp_CF,temp_Qv,temp_Qc,temp_Qi,temp_Qs,   &
4738      &                temp_Dz, temp_P, temp_T, temp_xland, gridkm,      &
4739      &                config_flags%insert_init_cloud, max_relh,         &
4740      &                kts, kte-1, debug_flag)
4741
4742             do k = kts, kte-1
4743                grid%cldfra(i,k,j) = temp_CF(k)
4744             enddo
4745
4746             if (debug_flag) then
4747             do k = kts, kte-1
4748               write(*,*) ' DEBUG_column: ', temp_P(k), temp_T(k), temp_Qv(k), temp_Qc(k), temp_Qi(k), moist(i,k,j,P_QC), moist(i,k,j,P_QI)
4749             enddo
4750             endif
4751
4752             do k = kts, kte-1
4753                moist(i,k,j,P_QV) = MAX(temp_Qv(k), moist(i,k,j,P_QV))
4754                moist(i,k,j,P_QC) = temp_Qc(k)
4755                moist(i,k,j,P_QI) = temp_Qi(k)
4756             enddo
4757
4758          enddo
4759          enddo
4760
4761          DEALLOCATE(temp_P)
4762          DEALLOCATE(temp_Dz)
4763          DEALLOCATE(temp_T)
4764          DEALLOCATE(temp_R)
4765          DEALLOCATE(temp_Qv)
4766          DEALLOCATE(temp_Qc)
4767          DEALLOCATE(temp_Nc)
4768          DEALLOCATE(temp_Qi)
4769          DEALLOCATE(temp_Ni)
4770          DEALLOCATE(temp_Qs)
4771          DEALLOCATE(temp_CF)
4772
4773       endif
4774
4775 !+---+-----------------------------------------------------------------+
4776 !..Let us ensure that double-moment microphysics variables have numbers
4777 !.. where there is mass.  Currently doing this for Thompson-MP only, but
4778 !.. can consider doing it for every MP scheme that has 2-moment variables.
4779 !.. This is important because pressure-level RAP/HRRR files have mass but
4780 !.. not number values for example (whereas native model level files have
4781 !.. both).
4782 !+---+-----------------------------------------------------------------+
4783
4784       IF ( config_flags%mp_physics .EQ. THOMPSON .OR.                   &
4785                    config_flags%mp_physics .EQ. THOMPSONAERO ) THEN
4786
4787          !..As it occurs up above, temporarily utilizing the v_1 variable,
4788          !.. to hold temperature, which it does when time_loop=0.
4789
4790          IF ( internal_time_loop .GT. 1 ) THEN
4791             grid%v_1 = grid%t_2+t0
4792
4793             CALL theta_to_t ( grid%v_1 , grid%p_hyd  , p00 , &
4794                            ids , ide , jds , jde , kds , kde , &
4795                            ims , ime , jms , jme , kms , kme , &
4796                            its , ite , jts , jte , kts , kte )
4797          ENDIF
4798
4799
4800          do j = jts, MIN(jte,jde-1)
4801          do i = its, MIN(ite,ide-1)
4802
4803             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4804
4805             do k = kts, kte-1
4806                temp_rho = 1./grid%alt(i,k,j)
4807
4808                !..Produce a sensible cloud droplet number concentration
4809
4810                if (P_QNC.gt.1 .AND. moist(i,k,j,P_QC).gt.0.0 .AND. scalar(i,k,j,P_QNC).le.0.0) then
4811                   if (P_QNWFA .gt. 1) then
4812                      scalar(i,k,j,P_QNC) = make_DropletNumber (moist(i,k,j,P_QC)*temp_rho,       &
4813      &                           scalar(i,k,j,P_QNWFA)*temp_rho, grid%xland(i,j))
4814                   else
4815                      scalar(i,k,j,P_QNC) = make_DropletNumber (moist(i,k,j,P_QC)*temp_rho,       &
4816      &                           0.0, grid%xland(i,j))
4817                   endif
4818                   scalar(i,k,j,P_QNC) = scalar(i,k,j,P_QNC) / temp_rho
4819                endif
4820
4821                !..Produce a sensible cloud ice number concentration
4822
4823                if (P_QNI.gt.1 .AND. moist(i,k,j,P_QI).gt.0.0 .AND. scalar(i,k,j,P_QNI).le.0.0) then
4824                   scalar(i,k,j,P_QNI) = make_IceNumber (moist(i,k,j,P_QI)*temp_rho, grid%v_1(i,k,j))
4825                   scalar(i,k,j,P_QNI) = scalar(i,k,j,P_QNI) / temp_rho
4826                endif
4827
4828                !..Produce a sensible rain number concentration
4829
4830                if (P_QNR.gt.1 .AND. moist(i,k,j,P_QR).gt.0.0 .AND. scalar(i,k,j,P_QNR).le.0.0) then
4831                   scalar(i,k,j,P_QNR) = make_RainNumber (moist(i,k,j,P_QR)*temp_rho, grid%v_1(i,k,j))
4832                   scalar(i,k,j,P_QNR) = scalar(i,k,j,P_QNR) / temp_rho
4833                endif
4834
4835             enddo
4836
4837          enddo
4838          enddo
4839
4840       ENDIF
4841
4842       if (config_flags%madwrf_cldinit == 1)  &
4843           call Init_madwrf_clouds (moist, p_qv, p_qc, p_qi, p_qs, p00, grid%t_2, grid%p_hyd, grid%ph_2, grid%phb,      &
4844             grid%alt, grid%xland, grid%cldmask, grid%cldtopz, grid%cldbasez, grid%brtemp, grid%ht, grid%dx, grid%dy,   &
4845             flag_cldmask, flag_cldtopz, flag_cldbasez, flag_brtemp, em_width, hold_ups, ids, ide, jds, jde, its, ims,  &
4846             ime, jms, jme, kms, kme, ite, jts, jte, kts, kte, grid%cldfra)
4847
4848         ! MAD-WRF tracers initialization
4849       if (config_flags%madwrf_opt == 2) then
4850         if (f_qc .and. f_qi .and. f_qs) then
4851           call Init_madwrf_tracers (tracer, moist, p_qc, p_qi, p_qs, p_tr_qc, p_tr_qi, p_tr_qs, &
4852               ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
4853         else
4854           call wrf_error_fatal('madwrf_opt=2 requires a mp_physics option with qc, qi and qs')
4855         end if
4856       end if
4857
4858 !+---+-----------------------------------------------------------------+
4859       !  Added by Greg Thompson.  Pre-set snow depth by latitude, elevation, and day-of-year.
4860
4861 !     CALL wrf_debug ( 0 , ' calling routine to add snow in high mountain peaks')
4862 !     DO j = jts, min(jde-1,jte)
4863 !        DO i = its, min(ide-1,ite)
4864 !           IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4865 !           grid%snowh(i,j) = snowHires (grid%snowh(i,j), grid%xlat(i,j), grid%ht(i,j), current_date, i,j)
4866 !           grid%snow(i,j) = grid%snowh(i,j) * 1000. / 5.
4867 !        END DO
4868 !     END DO
4869 !     CALL wrf_debug ( 0 , '   DONE routine to add snow in high mountain peaks')
4870 !+---+-----------------------------------------------------------------+
4871
4872 ! checking whether var_sso exists in the domain
4873       ! if so, we set got_var_sso flag to true.  This is later used in external/RSL_LITE/module_dm.F
4874       ! to check for this, when the topo_wind option is used.
4875       grid%got_var_sso = .FALSE.
4876       DO j=jts,MIN(jde-1,jte)
4877          DO i=its,MIN(ide-1,ite)
4878            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4879                IF(grid%var_sso(i,j) .NE. 0) THEN
4880                     grid%got_var_sso = .true.
4881                ENDIF
4882          END DO
4883       END DO
4884 #if ( defined(DM_PARALLEL)  &&   ! defined(STUBMPI) )
4885       grid%got_var_sso = wrf_dm_lor_logical ( grid%got_var_sso )
4886 #endif
4887
4888       !  Save the dry perturbation potential temperature.
4889
4890       DO j = jts, min(jde-1,jte)
4891          DO k = kts, kte
4892             DO i = its, min(ide-1,ite)
4893                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4894                grid%th_phy_m_t0(i,k,j) = grid%t_2(i,k,j)
4895             END DO
4896          END DO
4897       END DO
4898
4899       !  Turn dry potential temperature into moist potential temperature
4900       !  at the very end of this routine, just before the halo communications.
4901       !  This field will be in the model IC and and used to construct the
4902       !  BC file.
4903
4904       IF ( ( config_flags%use_theta_m .EQ. 1 ) .AND. (P_Qv .GE. PARAM_FIRST_SCALAR) ) THEN
4905          DO j = jts, min(jde-1,jte)
4906             DO k = kts, kte
4907                DO i = its, min(ide,ite)
4908                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4909                   grid%t_2(i,k,j) = ( grid%t_2(i,k,j) + T0 ) * (1. + (R_v/R_d) * moist(i,k,j,P_QV)) - T0
4910                END DO
4911             END DO
4912          END DO
4913       END IF
4914
4915 #ifdef DM_PARALLEL
4916 # include "HALO_EM_INIT_1.inc"
4917 # include "HALO_EM_INIT_2.inc"
4918 # include "HALO_EM_INIT_3.inc"
4919 # include "HALO_EM_INIT_4.inc"
4920 # include "HALO_EM_INIT_5.inc"
4921       IF ( config_flags%sf_ocean_physics .EQ. PWP3DSCHEME ) THEN
4922 # include "HALO_EM_INIT_6.inc"
4923       END IF
4924 #endif
4925
4926       RETURN
4927
4928    END SUBROUTINE init_domain_rk
4929
4930 !---------------------------------------------------------------------
4931
4932    SUBROUTINE const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat )
4933       USE module_configure
4934       IMPLICIT NONE
4935       !  For the real-data-cases only.
4936       REAL , INTENT(OUT) :: p00 , t00 , a , tiso , p_strat , a_strat
4937       CALL nl_get_base_pres        ( 1 , p00     )
4938       CALL nl_get_base_temp        ( 1 , t00     )
4939       CALL nl_get_base_lapse       ( 1 , a       )
4940       CALL nl_get_iso_temp         ( 1 , tiso    )
4941       CALL nl_get_base_pres_strat  ( 1 , p_strat )
4942       CALL nl_get_base_lapse_strat ( 1 , a_strat )
4943    END SUBROUTINE const_module_initialize
4944
4945 !-------------------------------------------------------------------
4946
4947    SUBROUTINE rebalance_driver ( grid )
4948
4949       IMPLICIT NONE
4950
4951       TYPE (domain)          :: grid
4952
4953       CALL rebalance( grid &
4954 !
4955 #include "actual_new_args.inc"
4956 !
4957       )
4958
4959    END SUBROUTINE rebalance_driver
4960
4961 !---------------------------------------------------------------------
4962
4963    SUBROUTINE rebalance ( grid  &
4964 !
4965 #include "dummy_new_args.inc"
4966 !
4967                         )
4968       IMPLICIT NONE
4969
4970       TYPE (domain)          :: grid
4971
4972 #include "dummy_new_decl.inc"
4973
4974       TYPE (grid_config_rec_type)              :: config_flags
4975
4976       REAL :: p_surf ,  pd_surf, p_surf_int , pb_int , ht_hold
4977       REAL :: qvf , qvf1 , qvf2
4978       REAL :: p00 , t00 , a , tiso , p_strat , a_strat
4979       REAL , DIMENSION(:,:,:) , ALLOCATABLE :: t_init_int
4980
4981       !  Local domain indices and counters.
4982
4983       INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
4984
4985       INTEGER                             ::                       &
4986                                      ids, ide, jds, jde, kds, kde, &
4987                                      ims, ime, jms, jme, kms, kme, &
4988                                      its, ite, jts, jte, kts, kte, &
4989                                      ips, ipe, jps, jpe, kps, kpe, &
4990                                      i, j, k, kk
4991
4992       REAL    :: temp, temp_int
4993       REAL    :: pfu, pfd, phm
4994       REAL    :: w1, w2, z0, z1, z2
4995
4996       SELECT CASE ( model_data_order )
4997          CASE ( DATA_ORDER_ZXY )
4998             kds = grid%sd31 ; kde = grid%ed31 ;
4999             ids = grid%sd32 ; ide = grid%ed32 ;
5000             jds = grid%sd33 ; jde = grid%ed33 ;
5001
5002             kms = grid%sm31 ; kme = grid%em31 ;
5003             ims = grid%sm32 ; ime = grid%em32 ;
5004             jms = grid%sm33 ; jme = grid%em33 ;
5005
5006             kts = grid%sp31 ; kte = grid%ep31 ;   ! note that tile is entire patch
5007             its = grid%sp32 ; ite = grid%ep32 ;   ! note that tile is entire patch
5008             jts = grid%sp33 ; jte = grid%ep33 ;   ! note that tile is entire patch
5009
5010          CASE ( DATA_ORDER_XYZ )
5011             ids = grid%sd31 ; ide = grid%ed31 ;
5012             jds = grid%sd32 ; jde = grid%ed32 ;
5013             kds = grid%sd33 ; kde = grid%ed33 ;
5014
5015             ims = grid%sm31 ; ime = grid%em31 ;
5016             jms = grid%sm32 ; jme = grid%em32 ;
5017             kms = grid%sm33 ; kme = grid%em33 ;
5018
5019             its = grid%sp31 ; ite = grid%ep31 ;   ! note that tile is entire patch
5020             jts = grid%sp32 ; jte = grid%ep32 ;   ! note that tile is entire patch
5021             kts = grid%sp33 ; kte = grid%ep33 ;   ! note that tile is entire patch
5022
5023          CASE ( DATA_ORDER_XZY )
5024             ids = grid%sd31 ; ide = grid%ed31 ;
5025             kds = grid%sd32 ; kde = grid%ed32 ;
5026             jds = grid%sd33 ; jde = grid%ed33 ;
5027
5028             ims = grid%sm31 ; ime = grid%em31 ;
5029             kms = grid%sm32 ; kme = grid%em32 ;
5030             jms = grid%sm33 ; jme = grid%em33 ;
5031
5032             its = grid%sp31 ; ite = grid%ep31 ;   ! note that tile is entire patch
5033             kts = grid%sp32 ; kte = grid%ep32 ;   ! note that tile is entire patch
5034             jts = grid%sp33 ; jte = grid%ep33 ;   ! note that tile is entire patch
5035
5036       END SELECT
5037
5038       ALLOCATE ( t_init_int(ims:ime,kms:kme,jms:jme) )
5039
5040       !  Fill config_flags the options for a particular domain
5041
5042       CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
5043
5044       !  Some of the many weird geopotential initializations that we'll see today: grid%ph0 is total,
5045       !  and grid%ph_2 is a perturbation from the base state geopotential.  We set the base geopotential
5046       !  at the lowest level to terrain elevation * gravity.
5047
5048       DO j=jts,jte
5049          DO i=its,ite
5050             grid%ph0(i,1,j) = grid%ht_fine(i,j) * g
5051             grid%ph_2(i,1,j) = 0.
5052          END DO
5053       END DO
5054
5055       !  To define the base state, we call a USER MODIFIED routine to set the three
5056       !  necessary constants:  p00 (sea level pressure, Pa), t00 (sea level temperature, K),
5057       !  and A (temperature difference, from 1000 mb to 300 mb, K), and constant stratosphere
5058       !  temp (tiso, K) either from input file or from namelist (for backward compatibiliy).
5059
5060       IF ( config_flags%use_baseparam_fr_nml ) then
5061       ! get these from namelist
5062          CALL wrf_message('ndown: using namelist constants')
5063          CALL const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat )
5064       ELSE
5065       ! get these constants from model data
5066          CALL wrf_debug(99,'ndown: using base-state profile constants from input file')
5067          t00     = grid%t00
5068          p00     = grid%p00
5069          a       = grid%tlp
5070          tiso    = grid%tiso
5071          p_strat = grid%p_strat
5072          a_strat = grid%tlp_strat
5073
5074          IF (t00 .LT. 100. .or. p00 .LT. 10000.) THEN
5075             WRITE(wrf_err_message,*)&
5076       'ndown_em: did not find base state parameters in wrfout. Add use_baseparam_fr_nml = .t. in &dynamics and rerun'
5077             CALL wrf_error_fatal(TRIM(wrf_err_message))
5078          ENDIF
5079       ENDIF
5080
5081       hold_ups = .true.
5082
5083       !  Base state potential temperature and inverse density (alpha = 1/rho) from
5084       !  the half eta levels and the base-profile surface pressure.  Compute 1/rho
5085       !  from equation of state.  The potential temperature is a perturbation from t0.
5086
5087       DO j = jts, MIN(jte,jde-1)
5088          DO i = its, MIN(ite,ide-1)
5089
5090             !  Base state pressure is a function of eta level and terrain, only, plus
5091             !  the hand full of constants: p00 (sea level pressure, Pa), t00 (sea level
5092             !  temperature, K), and A (temperature difference, from 1000 mb to 300 mb, K).
5093             !  The fine grid terrain is ht_fine, the interpolated is grid%ht.
5094
5095             p_surf     = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht_fine(i,j)/a/r_d ) **0.5 )
5096             p_surf_int = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)     /a/r_d ) **0.5 )
5097
5098             DO k = 1, kte-1
5099                grid%pb(i,k,j) = grid%c3h(k)*(p_surf     - grid%p_top) + grid%c4h(k) + grid%p_top
5100                pb_int    = grid%c3h(k)*(p_surf_int - grid%p_top) + grid%c4h(k) + grid%p_top
5101                temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) )
5102                IF ( grid%pb(i,k,j) .LT. p_strat ) THEN
5103                   temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat )
5104                ENDIF
5105 !              temp =             t00 + A*LOG(pb/p00)
5106                grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0
5107 !              grid%t_init(i,k,j)    = (t00 + A*LOG(grid%pb(i,k,j)/p00))*(p00/grid%pb(i,k,j))**(r_d/cp) - t0
5108                temp_int = MAX ( tiso, t00 + A*LOG(pb_int   /p00) )
5109                IF ( pb_int .LT. p_strat ) THEN
5110                   temp_int = tiso + A_strat * LOG ( pb_int/p_strat )
5111                ENDIF
5112                t_init_int(i,k,j)= temp_int*(p00/pb_int   )**(r_d/cp) - t0
5113 !              t_init_int(i,k,j)= (t00 + A*LOG(pb_int   /p00))*(p00/pb_int   )**(r_d/cp) - t0
5114                grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm
5115             END DO
5116             !  Base state mu is defined as base state surface pressure minus grid%p_top
5117             grid%MUB(i,j) = p_surf - grid%p_top
5118             !  Dry surface pressure is defined as the following (this mu is from the input file
5119             !  computed from the dry pressure).  Here the dry pressure is just reconstituted.
5120             pd_surf = ( grid%MUB(i,j) + grid%MU_2(i,j) ) + grid%p_top
5121             !  Integrate base geopotential, starting at terrain elevation.  This assures that
5122             !  the base state is in exact hydrostatic balance with respect to the model equations.
5123             !  This field is on full levels.
5124             grid%phb(i,1,j) = grid%ht_fine(i,j) * g
5125             IF (grid%hypsometric_opt == 1) THEN
5126               DO kk = 2,kte
5127                  k = kk - 1
5128                  grid%phb(i,kk,j) = grid%phb(i,kk-1,j) - grid%dnw(kk-1)*(grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))*grid%alb(i,kk-1,j)
5129               END DO
5130             ELSE IF (grid%hypsometric_opt == 2) THEN
5131               DO k = 2,kte
5132                  pfu = grid%c3f(k  )*grid%MUB(i,j)+grid%c4f(k  ) + grid%p_top
5133                  pfd = grid%c3f(k-1)*grid%MUB(i,j)+grid%c4f(k-1) + grid%p_top
5134                  phm = grid%c3h(k-1)*grid%MUB(i,j)+grid%c4h(k-1) + grid%p_top
5135                  grid%phb(i,k,j) = grid%phb(i,k-1,j) + grid%alb(i,k-1,j)*phm*LOG(pfd/pfu)
5136               END DO
5137             ELSE
5138               CALL wrf_error_fatal( 'initialize_real: hypsometric_opt should be 1 or 2' )
5139             END IF
5140          END DO
5141       END DO
5142       !  Replace interpolated terrain with fine grid values.
5143       DO j = jts, MIN(jte,jde-1)
5144          DO i = its, MIN(ite,ide-1)
5145             grid%ht(i,j) = grid%ht_fine(i,j)
5146          END DO
5147       END DO
5148       !  Perturbation fields.
5149       DO j = jts, min(jde-1,jte)
5150          DO i = its, min(ide-1,ite)
5151             !  The potential temperature is THETAnest = THETAinterp + ( TBARnest - TBARinterp)
5152             DO k =  1 , kde-1
5153                grid%t_2(i,k,j) = grid%t_2(i,k,j) + ( grid%t_init(i,k,j) - t_init_int(i,k,j) )
5154             END DO
5155             !  Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum
5156             !  equation) down from the top to get the pressure perturbation.  First get the pressure
5157             !  perturbation, moisture, and inverse density (total and perturbation) at the top-most level.
5158             kk = kte-1
5159             k = kk+1
5160             qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk,j,P_QV))
5161             qvf2 = 1./(1.+qvf1)
5162             qvf1 = qvf1*qvf2
5163             grid%p(i,kk,j) = - 0.5*((grid%c1f(k)*grid%Mu_2(i,j))+qvf1*(grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)))/grid%rdnw(kk)/qvf2
5164             qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
5165             IF ( config_flags%use_theta_m .EQ. 1 ) THEN
5166                grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)* &
5167                                   (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
5168             ELSE
5169                grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* &
5170                                   (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
5171             END IF
5172             grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
5173             grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
5174             !  Now, integrate down the column to compute the pressure perturbation, and diagnose the two
5175             !  inverse density fields (total and perturbation).
5176             DO kk=kte-2,1,-1
5177                k = kk+1
5178                qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk+1,j,P_QV))
5179                qvf2 = 1./(1.+qvf1)
5180                qvf1 = qvf1*qvf2
5181                grid%p(i,kk,j) = grid%p(i,kk+1,j) - ((grid%c1f(k)*grid%Mu_2(i,j)) + qvf1*(grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)))/qvf2/grid%rdn(kk+1)
5182                qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
5183                IF ( config_flags%use_theta_m .EQ. 1 ) THEN
5184                   grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)* &
5185                                      (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
5186                ELSE
5187                   grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* &
5188                                      (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
5189                END IF
5190                grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
5191                grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
5192             END DO
5193             !  This is the hydrostatic equation used in the model after the small timesteps.  In
5194             !  the model, grid%al (inverse density) is computed from the geopotential.
5195             IF (grid%hypsometric_opt == 1) THEN
5196                DO kk  = 2,kte
5197                   k = kk-1
5198                   grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - &
5199                                 grid%dnw(kk-1) * ( ((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mu_2(i,j)))*grid%al(i,kk-1,j) &
5200                               + (grid%c1h(k)*grid%mu_2(i,j))*grid%alb(i,kk-1,j) )
5201                   grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j)
5202                END DO
5203             ELSE IF (grid%hypsometric_opt == 2) THEN
5204              ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure.
5205              ! Note that al*p approximates Rd*T and dLOG(p) does z.
5206              ! Here T varies mostly linear with z, the first-order integration produces better result.
5207                grid%ph_2(i,1,j) = grid%phb(i,1,j)
5208                DO k = 2,kte
5209                   pfu = grid%c3f(k  )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k  )+grid%p_top
5210                   pfd = grid%c3f(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k-1)+grid%p_top
5211                   phm = grid%c3h(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4h(k-1)+grid%p_top
5212                   grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu)
5213                END DO
5214
5215                DO k = 1,kte
5216                   grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j)
5217                END DO
5218
5219                DO k = 1,kte
5220                   grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j)
5221                END DO
5222
5223             END IF
5224
5225 ! update psfc in fine grid
5226
5227             z0 = grid%ph0(i,1,j)/g
5228             z1 = 0.5*(grid%ph0(i,1,j)+grid%ph0(i,2,j))/g
5229             z2 = 0.5*(grid%ph0(i,2,j)+grid%ph0(i,3,j))/g
5230             w1 = (z0 - z2)/(z1 - z2)
5231             w2 = 1. - w1
5232             grid%psfc(i,j) = w1*(grid%p(i,1,j)+grid%pb(i,1,j))+w2*(grid%p(i,2,j)+grid%pb(i,2,j))
5233
5234          END DO
5235       END DO
5236
5237       DEALLOCATE ( t_init_int )
5238
5239       ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte
5240 #ifdef DM_PARALLEL
5241 # include "HALO_EM_INIT_1.inc"
5242 # include "HALO_EM_INIT_2.inc"
5243 # include "HALO_EM_INIT_3.inc"
5244 # include "HALO_EM_INIT_4.inc"
5245 # include "HALO_EM_INIT_5.inc"
5246 #endif
5247    END SUBROUTINE rebalance
5248
5249 !---------------------------------------------------------------------
5250
5251    RECURSIVE SUBROUTINE find_my_parent ( grid_ptr_in , grid_ptr_out , id_i_am , id_wanted , found_the_id )
5252
5253 !  RAR - Modified to correct problem in which the parent of a child domain could
5254 !  not be found in the namelist. This condition typically occurs while using the
5255 !  "allow_grid" namelist option when an inactive domain comes before an active
5256 !  domain in the list, i.e., the domain number of the active domain is greater than
5257 !  that of an inactive domain at the same level.
5258 !
5259       USE module_domain
5260
5261       TYPE(domain) , POINTER :: grid_ptr_in , grid_ptr_out
5262       TYPE(domain) , POINTER :: grid_ptr_sibling
5263       INTEGER :: id_wanted , id_i_am
5264       INTEGER :: nest                    ! RAR
5265       LOGICAL :: found_the_id
5266
5267       found_the_id = .FALSE.
5268       grid_ptr_sibling => grid_ptr_in
5269       nest = 0                           ! RAR
5270
5271       DO WHILE ( ASSOCIATED ( grid_ptr_sibling ) )
5272
5273          IF ( grid_ptr_sibling%grid_id .EQ. id_wanted ) THEN
5274             found_the_id = .TRUE.
5275             grid_ptr_out => grid_ptr_sibling
5276             RETURN
5277 ! RAR    ELSE IF ( grid_ptr_sibling%num_nests .GT. 0 ) THEN
5278          ELSE IF ( grid_ptr_sibling%num_nests .GT. 0 .AND. nest .LT. grid_ptr_sibling%num_nests ) THEN
5279             nest = nest + 1               ! RAR
5280             grid_ptr_sibling => grid_ptr_sibling%nests(nest)%ptr ! RAR
5281             CALL find_my_parent ( grid_ptr_sibling , grid_ptr_out , id_i_am , id_wanted , found_the_id )
5282             IF (.NOT. found_the_id) grid_ptr_sibling => grid_ptr_sibling%parents(1)%ptr   ! RAR
5283          ELSE
5284             grid_ptr_sibling => grid_ptr_sibling%sibling
5285          END IF
5286
5287       END DO
5288
5289    END SUBROUTINE find_my_parent
5290
5291 !---------------------------------------------------------------------
5292
5293    RECURSIVE SUBROUTINE find_my_parent2 ( grid_ptr_in , grid_ptr_out , id_wanted , found_the_id )
5294
5295       USE module_domain
5296
5297       TYPE(domain) , POINTER               :: grid_ptr_in
5298       TYPE(domain) , POINTER               :: grid_ptr_out
5299       INTEGER                , INTENT(IN ) :: id_wanted
5300       LOGICAL                , INTENT(OUT) :: found_the_id
5301
5302       !  Local
5303
5304       TYPE(domain) , POINTER :: grid_ptr_holder
5305       INTEGER :: kid
5306
5307       !  Initializations
5308
5309       found_the_id = .FALSE.
5310       grid_ptr_holder => grid_ptr_in
5311
5312
5313       !  Have we found the correct location?  If so, we can just pop back up with
5314       !  the pointer to the right location (i.e. the parent), thank you very much.
5315
5316       IF ( id_wanted .EQ. grid_ptr_in%grid_id ) THEN
5317
5318          found_the_id = .TRUE.
5319          grid_ptr_out => grid_ptr_in
5320
5321
5322       !  We gotta keep looking.
5323
5324       ELSE
5325
5326       !  We drill down and process each nest from this domain.  We don't have to
5327       !  worry about siblings, as we are running over all of the kids for this parent,
5328       !  so it amounts to the same set of domains being tested.
5329
5330          loop_over_all_kids : DO kid = 1 , grid_ptr_in%num_nests
5331
5332             IF ( ASSOCIATED ( grid_ptr_in%nests(kid)%ptr ) ) THEN
5333
5334                CALL find_my_parent2 ( grid_ptr_in%nests(kid)%ptr , grid_ptr_out , id_wanted , found_the_id )
5335                IF ( found_the_id ) THEN
5336                   EXIT loop_over_all_kids
5337                END IF
5338
5339             END IF
5340          END DO loop_over_all_kids
5341
5342       END IF
5343
5344    END SUBROUTINE find_my_parent2
5345
5346 #endif
5347
5348 !---------------------------------------------------------------------
5349
5350 #ifdef VERT_UNIT
5351
5352 !gfortran -DVERT_UNIT -ffree-form -ffree-line-length-none module_initialize_real.F -o vert.exe
5353
5354 !This is a main program for a small unit test for the vertical interpolation.
5355
5356 program vint
5357
5358    implicit none
5359
5360    integer , parameter :: ij = 3
5361    integer , parameter :: keta = 30
5362    integer , parameter :: kgen =20
5363
5364    integer :: ids , ide , jds , jde , kds , kde , &
5365               ims , ime , jms , jme , kms , kme , &
5366               its , ite , jts , jte , kts , kte
5367
5368    integer :: generic
5369
5370    real , dimension(1:ij,kgen,1:ij) :: fo , po
5371    real , dimension(1:ij,1:keta,1:ij) :: fn_calc , fn_interp , pn
5372    real , dimension(1:ij,1:ij) :: not_required_2d_1, not_required_2d_2, &
5373                                   not_required_2d_3, not_required_2d_4, &
5374                                   not_required_2d_5, not_required_2d_6
5375
5376    integer, parameter :: interp_type             = 1 ! 2
5377    integer, parameter :: extrap_type             = 2 ! 1
5378 !  integer, parameter :: lagrange_order          = 2 ! 1
5379    integer            :: lagrange_order
5380    logical, parameter :: lowest_lev_from_sfc     = .FALSE. ! .TRUE.
5381    logical, parameter :: use_levels_below_ground = .TRUE. ! .FALSE. ! .TRUE.
5382    logical, parameter :: use_surface             = .TRUE. ! .FALSE. ! .TRUE.
5383    real   , parameter :: zap_close_levels        = 500. ! 100.
5384    integer, parameter :: force_sfc_in_vinterp    = 6 ! 0 ! 6
5385    integer, parameter :: id                      = 1
5386
5387    integer :: k
5388
5389    ids = 1 ; ide = ij ; jds = 1 ; jde = ij ; kds = 1 ; kde = keta
5390    ims = 1 ; ime = ij ; jms = 1 ; jme = ij ; kms = 1 ; kme = keta
5391    its = 1 ; ite = ij ; jts = 1 ; jte = ij ; kts = 1 ; kte = keta
5392
5393    generic = kgen
5394
5395    print *,' '
5396    print *,'------------------------------------'
5397    print *,'UNIT TEST FOR VERTICAL INTERPOLATION'
5398    print *,'------------------------------------'
5399    print *,' '
5400    do lagrange_order = 1 , 1
5401       print *,' '
5402       print *,'------------------------------------'
5403       print *,'Lagrange Order = ',lagrange_order
5404       print *,'------------------------------------'
5405       print *,' '
5406       call fillitup ( fo , po , fn_calc , pn , &
5407                     ids , ide , jds , jde , kds , kde , &
5408                     ims , ime , jms , jme , kms , kme , &
5409                     its , ite , jts , jte , kts , kte , &
5410                     generic , lagrange_order )
5411
5412       print *,' '
5413       print *,'Level   Pressure     Field'
5414       print *,'          (Pa)      (generic)'
5415       print *,'------------------------------------'
5416       print *,' '
5417       do k = 1 , generic
5418       write (*,fmt='(i2,2x,f12.3,1x,g15.8)' ) &
5419          k,po(2,k,2),fo(2,k,2)
5420       end do
5421       print *,' '
5422
5423       call vert_interp ( fo , po , fn_interp , pn , &
5424                          not_required_2d_1, not_required_2d_2, &
5425                          not_required_2d_3, not_required_2d_4, &
5426                          not_required_2d_5, not_required_2d_6, &
5427                          0 , 0, 5000., 5000., 30000., &
5428                          generic , 'T' , &
5429                          interp_type , lagrange_order , extrap_type , &
5430                          lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
5431                          zap_close_levels , force_sfc_in_vinterp , id , &
5432                          ids , ide , jds , jde , kds , kde , &
5433                          ims , ime , jms , jme , kms , kme , &
5434                          its , ite , jts , jte , kts , kte )
5435
5436       print *,'Multi-Order Interpolator'
5437       print *,'------------------------------------'
5438       print *,' '
5439       print *,'Level  Pressure      Field           Field         Field'
5440       print *,'         (Pa)        Calc            Interp        Diff'
5441       print *,'------------------------------------'
5442       print *,' '
5443       do k = kts , kte-1
5444       write (*,fmt='(i2,2x,f12.3,1x,3(g15.7))' ) &
5445          k,pn(2,k,2),fn_calc(2,k,2),fn_interp(2,k,2),fn_calc(2,k,2)-fn_interp(2,k,2)
5446       end do
5447
5448    end do
5449
5450 end program vint
5451
5452 subroutine wrf_error_fatal (string)
5453    character (len=*) :: string
5454    print *,string
5455    stop
5456 end subroutine wrf_error_fatal
5457
5458 subroutine fillitup ( fo , po , fn , pn , &
5459                     ids , ide , jds , jde , kds , kde , &
5460                     ims , ime , jms , jme , kms , kme , &
5461                     its , ite , jts , jte , kts , kte , &
5462                     generic , lagrange_order )
5463
5464    implicit none
5465
5466    integer , intent(in) :: ids , ide , jds , jde , kds , kde , &
5467               ims , ime , jms , jme , kms , kme , &
5468               its , ite , jts , jte , kts , kte
5469
5470    integer , intent(in) :: generic , lagrange_order
5471
5472    real , dimension(ims:ime,generic,jms:jme) , intent(out) :: fo , po
5473    real , dimension(ims:ime,kms:kme,jms:jme) , intent(out) :: fn , pn
5474
5475    integer :: i , j , k
5476
5477    k = 1
5478    do j = jts , jte
5479    do i = its , ite
5480       po(i,k,j) = 102000.
5481    end do
5482    end do
5483
5484    do k = 2 , generic
5485    do j = jts , jte
5486    do i = its , ite
5487       po(i,k,j) = ( 5000. * ( 1 - (k-1) ) + 100000. * ( (k-1) - (generic-1) ) ) / (1. - real(generic-1) )
5488 !     po(i,k,j) = FILL IN YOUR INPUT PRESSURE LEVELS
5489    end do
5490    end do
5491    end do
5492
5493    if ( lagrange_order .eq. 1 ) then
5494       do k = 1 , generic
5495       do j = jts , jte
5496       do i = its , ite
5497          fo(i,k,j) = po(i,k,j)
5498 !        fo(i,k,j) = FILL IN YOUR COLUMN OF PRESS_LEVEL FIELD
5499       end do
5500       end do
5501       end do
5502    else if ( lagrange_order .eq. 2 ) then
5503       do k = 1 , generic
5504       do j = jts , jte
5505       do i = its , ite
5506          fo(i,k,j) = (((po(i,k,j)-5000.)/102000.)*((102000.-po(i,k,j))/102000.))*102000.
5507       end do
5508       end do
5509       end do
5510    end if
5511
5512 !!!!!!!!!!!!
5513
5514    do k = kts , kte
5515    do j = jts , jte
5516    do i = its , ite
5517       pn(i,k,j) = ( 5000. * ( 0 - (k-1) ) + 102000. * ( (k-1) - (kte-1) ) ) / (-1. *  real(kte-1) )
5518 !     pn(i,k,j) = FILL IN A COLUMN OF KNOWN FULL-LEVEL PRESSURES ON ETA SURFACES
5519    end do
5520    end do
5521    end do
5522
5523    do k = kts , kte-1
5524    do j = jts , jte
5525    do i = its , ite
5526       pn(i,k,j) = ( pn(i,k,j) + pn(i,k+1,j) ) /2.
5527    end do
5528    end do
5529    end do
5530
5531
5532    if ( lagrange_order .eq. 1 ) then
5533       do k = kts , kte-1
5534       do j = jts , jte
5535       do i = its , ite
5536          fn(i,k,j) = pn(i,k,j)
5537 !        fn(i,k,j) = FILL IN COLUMN OF HALF LEVEL FIELD
5538       end do
5539       end do
5540       end do
5541    else if ( lagrange_order .eq. 2 ) then
5542       do k = kts , kte-1
5543       do j = jts , jte
5544       do i = its , ite
5545          fn(i,k,j) = (((pn(i,k,j)-5000.)/102000.)*((102000.-pn(i,k,j))/102000.))*102000.
5546 !        fn(i,k,j) = sin(pn(i,k,j) * piov2 / 102000. )
5547       end do
5548       end do
5549       end do
5550    end if
5551
5552 end subroutine fillitup
5553
5554 function skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups )
5555    logical :: skip_middle_points_t
5556    integer :: ids , ide , jds , jde , i , j , em_width
5557    logical :: hold_ups
5558    skip_middle_points_t = .false.
5559 end function skip_middle_points_t
5560
5561 subroutine wrf_message(level,message)
5562    character(len=*), intent(in) :: message
5563    integer, intent(in) :: level
5564    print *,trim(message)
5565 end subroutine wrf_message
5566
5567 #endif
5568
5569 !---------------------------------------------------------------------
5570
5571    SUBROUTINE vert_interp ( fo , po , fnew , pnu , &
5572                             fo_maxw , fo_trop , po_maxw , po_trop , &
5573                             po_maxwnn , po_tropnn , &
5574                             flag_maxw , flag_trop , &
5575                             maxw_horiz_pres_diff , trop_horiz_pres_diff , &
5576                             maxw_above_this_level , &
5577                             generic , var_type , &
5578                             interp_type , lagrange_order , extrap_type , &
5579                             lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
5580                             zap_close_levels , force_sfc_in_vinterp , id , &
5581                             ids , ide , jds , jde , kds , kde , &
5582                             ims , ime , jms , jme , kms , kme , &
5583                             its , ite , jts , jte , kts , kte )
5584
5585    !  Vertically interpolate the new field.  The original field on the original
5586    !  pressure levels is provided, and the new pressure surfaces to interpolate to.
5587
5588       IMPLICIT NONE
5589
5590       INTEGER , INTENT(IN)        :: interp_type , lagrange_order , extrap_type
5591       LOGICAL , INTENT(IN)        :: lowest_lev_from_sfc , use_levels_below_ground , use_surface
5592       REAL    , INTENT(IN)        :: zap_close_levels
5593       REAL    , INTENT(IN)        :: maxw_horiz_pres_diff , trop_horiz_pres_diff , maxw_above_this_level
5594       INTEGER , INTENT(IN)        :: force_sfc_in_vinterp , id
5595       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
5596                                      ims , ime , jms , jme , kms , kme , &
5597                                      its , ite , jts , jte , kts , kte
5598       INTEGER , INTENT(IN)        :: generic
5599       INTEGER , INTENT(IN)        :: flag_maxw , flag_trop
5600
5601       CHARACTER (LEN=1) :: var_type
5602
5603       REAL , DIMENSION(ims:ime,generic,jms:jme) , INTENT(IN)     :: fo , po
5604       REAL , DIMENSION(ims:ime,jms:jme)         , INTENT(IN)     :: fo_maxw , fo_trop , po_maxw , po_trop
5605       REAL , DIMENSION(ims:ime,jms:jme)         , INTENT(IN)     :: po_maxwnn , po_tropnn
5606       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN)     :: pnu
5607       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT)    :: fnew
5608
5609       REAL , DIMENSION(ims:ime,generic,jms:jme)                  :: forig , porig
5610       REAL , DIMENSION(ims:ime,jms:jme)                          :: forig_maxw , forig_trop , porig_maxw , porig_trop
5611       REAL , DIMENSION(ims:ime,kms:kme,jms:jme)                  :: pnew
5612
5613       !  Local vars
5614
5615       CHARACTER (LEN=256) :: message
5616       INTEGER :: i , j , k , ko , kn , k1 , k2 , ko_1 , ko_2 , knext
5617       INTEGER :: istart , iend , jstart , jend , kstart , kend
5618       INTEGER , DIMENSION(ims:ime,kms:kme        )               :: k_above , k_below
5619       INTEGER , DIMENSION(ims:ime                )               :: ks
5620       INTEGER , DIMENSION(ims:ime                )               :: ko_above_sfc
5621       INTEGER :: count , zap , zap_below , zap_above , kst , kcount
5622       INTEGER :: kinterp_start , kinterp_end , sfc_level
5623
5624       LOGICAL :: any_below_ground
5625
5626       REAL :: p1 , p2 , pn, hold , zap_close_extra_levels
5627       REAL , DIMENSION(1:generic+flag_maxw+flag_trop) :: ordered_porig , ordered_forig
5628       REAL , DIMENSION(kts:kte) :: ordered_pnew , ordered_fnew
5629
5630       !  Excluded middle.
5631
5632       LOGICAL :: any_valid_points
5633       INTEGER :: i_valid , j_valid
5634       LOGICAL :: flip_data_required
5635 #ifdef VERT_UNIT
5636       LOGICAL, EXTERNAL :: skip_middle_points_t
5637       INTEGER :: em_width
5638       LOGICAL :: hold_ups
5639 #endif
5640       INTEGER :: final_zap_check_count , count_close_by_at_ko
5641
5642       !  Vertical interpolation of the extra levels from metgrid: max wind and tropopause
5643
5644       LOGICAL :: ok_data
5645       INTEGER :: ii, jj
5646
5647       zap_close_extra_levels = 500
5648
5649       !  Horiontal loop bounds for different variable types.
5650
5651       IF      ( var_type .EQ. 'U' ) THEN
5652          istart = its
5653          iend   = ite
5654          jstart = MAX(jds  ,jts-1)
5655          jend   = MIN(jde-1,jte+1)
5656          kstart = kts
5657          kend   = kte-1
5658          DO j = jstart,jend
5659             DO k = 1,generic
5660                DO i = MAX(ids+1,its-1) , MIN(ide-1,ite+1)
5661                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5662                   porig(i,k,j) = ( po(i,k,j) + po(i-1,k,j) ) * 0.5
5663                END DO
5664             END DO
5665             DO i = MAX(ids+1,its-1) , MIN(ide-1,ite+1)
5666                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5667                   porig_maxw(i,j) = ( po_maxw(i,j) + po_maxw(i-1,j) ) * 0.5
5668                   porig_trop(i,j) = ( po_trop(i,j) + po_trop(i-1,j) ) * 0.5
5669             END DO
5670             IF ( ids .EQ. its ) THEN
5671                DO k = 1,generic
5672                   porig(its,k,j) =  po(its,k,j)
5673                END DO
5674                porig_maxw(its,j) =  po_maxw(its,j)
5675                porig_trop(its,j) =  po_trop(its,j)
5676             END IF
5677             IF ( ide .EQ. ite ) THEN
5678                DO k = 1,generic
5679                   porig(ite,k,j) =  po(ite-1,k,j)
5680                END DO
5681                porig_maxw(ite,j) =  po_maxw(ite-1,j)
5682                porig_trop(ite,j) =  po_trop(ite-1,j)
5683             END IF
5684
5685             DO k = kstart,kend
5686                DO i = MAX(ids+1,its-1) , MIN(ide-1,ite+1)
5687                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5688                   pnew(i,k,j) = ( pnu(i,k,j) + pnu(i-1,k,j) ) * 0.5
5689                END DO
5690             END DO
5691             IF ( ids .EQ. its ) THEN
5692                DO k = kstart,kend
5693                   pnew(its,k,j) =  pnu(its,k,j)
5694                END DO
5695             END IF
5696             IF ( ide .EQ. ite ) THEN
5697                DO k = kstart,kend
5698                   pnew(ite,k,j) =  pnu(ite-1,k,j)
5699                END DO
5700             END IF
5701          END DO
5702       ELSE IF ( var_type .EQ. 'V' ) THEN
5703          istart = MAX(ids  ,its-1)
5704          iend   = MIN(ide-1,ite+1)
5705          jstart = jts
5706          jend   = jte
5707          kstart = kts
5708          kend   = kte-1
5709          DO i = istart,iend
5710             DO k = 1,generic
5711                DO j = MAX(jds+1,jts-1) , MIN(jde-1,jte+1)
5712                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5713                   porig(i,k,j) = ( po(i,k,j) + po(i,k,j-1) ) * 0.5
5714                END DO
5715             END DO
5716             DO j = MAX(jds+1,jts-1) , MIN(jde-1,jte+1)
5717                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5718                   porig_maxw(i,j) = ( po_maxw(i,j) + po_maxw(i,j-1) ) * 0.5
5719                   porig_trop(i,j) = ( po_trop(i,j) + po_trop(i,j-1) ) * 0.5
5720             END DO
5721             IF ( jds .EQ. jts ) THEN
5722                DO k = 1,generic
5723                   porig(i,k,jts) =  po(i,k,jts)
5724                END DO
5725                porig_maxw(i,jts) =  po_maxw(i,jts)
5726                porig_trop(i,jts) =  po_trop(i,jts)
5727             END IF
5728             IF ( jde .EQ. jte ) THEN
5729                DO k = 1,generic
5730                   porig(i,k,jte) =  po(i,k,jte-1)
5731                END DO
5732                porig_maxw(i,jte) =  po_maxw(i,jte-1)
5733                porig_trop(i,jte) =  po_trop(i,jte-1)
5734             END IF
5735
5736             DO k = kstart,kend
5737                DO j = MAX(jds+1,jts-1) , MIN(jde-1,jte+1)
5738                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5739                   pnew(i,k,j) = ( pnu(i,k,j) + pnu(i,k,j-1) ) * 0.5
5740                END DO
5741             END DO
5742             IF ( jds .EQ. jts ) THEN
5743                DO k = kstart,kend
5744                   pnew(i,k,jts) =  pnu(i,k,jts)
5745                END DO
5746             END IF
5747             IF ( jde .EQ. jte ) THEN
5748               DO k = kstart,kend
5749                   pnew(i,k,jte) =  pnu(i,k,jte-1)
5750                END DO
5751             END IF
5752          END DO
5753       ELSE IF ( ( var_type .EQ. 'W' ) .OR.  ( var_type .EQ. 'Z' ) ) THEN
5754          istart = its
5755          iend   = MIN(ide-1,ite)
5756          jstart = jts
5757          jend   = MIN(jde-1,jte)
5758          kstart = kts
5759          kend   = kte
5760          DO j = jstart,jend
5761             DO k = 1,generic
5762                DO i = istart,iend
5763                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5764                   porig(i,k,j) = po(i,k,j)
5765                END DO
5766             END DO
5767             DO i = istart,iend
5768                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5769                   porig_maxw(i,j) = po_maxw(i,j)
5770                   porig_trop(i,j) = po_trop(i,j)
5771             END DO
5772
5773             DO k = kstart,kend
5774                DO i = istart,iend
5775                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5776                   pnew(i,k,j) = pnu(i,k,j)
5777                END DO
5778             END DO
5779          END DO
5780       ELSE IF ( ( var_type .EQ. 'T' ) .OR. ( var_type .EQ. 'Q' ) ) THEN
5781          istart = its
5782          iend   = MIN(ide-1,ite)
5783          jstart = jts
5784          jend   = MIN(jde-1,jte)
5785          kstart = kts
5786          kend   = kte-1
5787          DO j = jstart,jend
5788             DO k = 1,generic
5789                DO i = istart,iend
5790                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5791                   porig(i,k,j) = po(i,k,j)
5792                END DO
5793             END DO
5794             DO i = istart,iend
5795                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5796                   porig_maxw(i,j) = po_maxw(i,j)
5797                   porig_trop(i,j) = po_trop(i,j)
5798             END DO
5799
5800             DO k = kstart,kend
5801                DO i = istart,iend
5802                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5803                   pnew(i,k,j) = pnu(i,k,j)
5804                END DO
5805             END DO
5806          END DO
5807       ELSE
5808          istart = its
5809          iend   = MIN(ide-1,ite)
5810          jstart = jts
5811          jend   = MIN(jde-1,jte)
5812          kstart = kts
5813          kend   = kte-1
5814          DO j = jstart,jend
5815             DO k = 1,generic
5816                DO i = istart,iend
5817                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5818                   porig(i,k,j) = po(i,k,j)
5819                END DO
5820             END DO
5821
5822             DO k = kstart,kend
5823                DO i = istart,iend
5824                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5825                   pnew(i,k,j) = pnu(i,k,j)
5826                END DO
5827             END DO
5828          END DO
5829       END IF
5830
5831       !  We need to find if there are any valid non-excluded-middle points in this
5832       !  tile.  If so, then we need to hang on to a valid i,j location.
5833
5834       any_valid_points = .false.
5835       find_valid : DO j = jstart , jend
5836          DO i = istart , iend
5837             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5838             any_valid_points = .true.
5839             i_valid = i
5840             j_valid = j
5841             EXIT find_valid
5842          END DO
5843       END DO find_valid
5844       IF ( .NOT. any_valid_points ) THEN
5845          RETURN
5846       END IF
5847
5848       IF ( porig(i_valid,2,j_valid) .LT. porig(i_valid,generic,j_valid) ) THEN
5849          flip_data_required = .true.
5850       ELSE
5851          flip_data_required = .false.
5852       END IF
5853
5854       DO j = jstart , jend
5855
5856          !  The lowest level is the surface.  Levels 2 through "generic" are supposed to
5857          !  be "bottom-up".  Flip if they are not.  This is based on the input pressure
5858          !  array.
5859
5860          IF ( flip_data_required ) THEN
5861             DO kn = 2 , ( generic + 1 ) / 2
5862                DO i = istart , iend
5863                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5864                   hold                    = porig(i,kn,j)
5865                   porig(i,kn,j)           = porig(i,generic+2-kn,j)
5866                   porig(i,generic+2-kn,j) = hold
5867                   forig(i,kn,j)           = fo   (i,generic+2-kn,j)
5868                   forig(i,generic+2-kn,j) = fo   (i,kn,j)
5869                END DO
5870             END DO
5871             DO i = istart , iend
5872                forig(i,1,j)               = fo   (i,1,j)
5873             END DO
5874             IF ( MOD(generic,2) .EQ. 0 ) THEN
5875                k=generic/2 + 1
5876                DO i = istart , iend
5877                   forig(i,k,j)            = fo   (i,k,j)
5878                END DO
5879             END IF
5880          ELSE
5881             DO kn = 1 , generic
5882                DO i = istart , iend
5883                   forig(i,kn,j)           = fo   (i,kn,j)
5884                END DO
5885             END DO
5886          END IF
5887
5888          !  Skip all of the levels below ground in the original data based upon the surface pressure.
5889          !  The ko_above_sfc is the index in the pressure array that is above the surface.  If there
5890          !  are no levels underground, this is index = 2.  The remaining levels are eligible for use
5891          !  in the vertical interpolation.
5892
5893          DO i = istart , iend
5894             ko_above_sfc(i) = -1
5895          END DO
5896          DO ko = kstart+1 , generic
5897             DO i = istart , iend
5898                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5899                IF ( ko_above_sfc(i) .EQ. -1 ) THEN
5900                   IF ( porig(i,1,j) .GT. porig(i,ko,j) ) THEN
5901                      ko_above_sfc(i) = ko
5902                   END IF
5903                END IF
5904             END DO
5905          END DO
5906
5907          !  Piece together columns of the original input data.  Pass the vertical columns to
5908          !  the iterpolator.
5909
5910          DO i = istart , iend
5911             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5912
5913             !  If the surface value is in the middle of the array, three steps: 1) do the
5914             !  values below the ground (this is just to catch the occasional value that is
5915             !  inconsistently below the surface based on input data), 2) do the surface level, then
5916             !  3) add in the levels that are above the surface.  For the levels next to the surface,
5917             !  we check to remove any levels that are "too close".  When building the column of input
5918             !  pressures, we also attend to the request for forcing the surface analysis to be used
5919             !  in a few lower eta-levels.
5920
5921             !  Fill in the column from up to the level just below the surface with the input
5922             !  presssure and the input field (orig or old, which ever).  For an isobaric input
5923             !  file, this data is isobaric.
5924
5925             !  How many levels have we skipped in the input column.
5926
5927             zap = 0
5928             zap_below = 0
5929             zap_above = 0
5930
5931             IF (  ko_above_sfc(i) .GT. 2 ) THEN
5932                count = 1
5933                DO ko = 2 , ko_above_sfc(i)-1
5934                   ordered_porig(count) = porig(i,ko,j)
5935                   ordered_forig(count) = forig(i,ko,j)
5936                   count = count + 1
5937                END DO
5938
5939                !  Make sure the pressure just below the surface is not "too close", this
5940                !  will cause havoc with the higher order interpolators.  In case of a "too close"
5941                !  instance, we toss out the offending level (NOT the surface one) by simply
5942                !  decrementing the accumulating loop counter.
5943
5944                IF ( ordered_porig(count-1) - porig(i,1,j) .LT. zap_close_levels ) THEN
5945                   count = count -1
5946                   zap = 1
5947                   zap_below = 1
5948                END IF
5949
5950                !  Add in the surface values.
5951
5952                ordered_porig(count) = porig(i,1,j)
5953                ordered_forig(count) = forig(i,1,j)
5954                count = count + 1
5955
5956                !  A usual way to do the vertical interpolation is to pay more attention to the
5957                !  surface data.  Why?  Well it has about 20x the density as the upper air, so we
5958                !  hope the analysis is better there.  We more strongly use this data by artificially
5959                !  tossing out levels above the surface that are beneath a certain number of prescribed
5960                !  eta levels at this (i,j).  The "zap" value is how many levels of input we are
5961                !  removing, which is used to tell the interpolator how many valid values are in
5962                !  the column.  The "count" value is the increment to the index of levels, and is
5963                !  only used for assignments.
5964
5965                IF ( force_sfc_in_vinterp .GT. 0 ) THEN
5966
5967                   !  Get the pressure at the eta level.  We want to remove all input pressure levels
5968                   !  between the level above the surface to the pressure at this eta surface.  That
5969                   !  forces the surface value to be used through the selected eta level.  Keep track
5970                   !  of two things: the level to use above the eta levels, and how many levels we are
5971                   !  skipping.
5972
5973                   knext = ko_above_sfc(i)
5974                   find_level : DO ko = ko_above_sfc(i) , generic
5975                      IF ( porig(i,ko,j) .LE. pnew(i,force_sfc_in_vinterp,j) ) THEN
5976                         knext = ko
5977                         exit find_level
5978                      ELSE
5979                         zap = zap + 1
5980                         zap_above = zap_above + 1
5981                      END IF
5982                   END DO find_level
5983
5984                !  No request for special interpolation, so we just assign the next level to use
5985                !  above the surface as, ta da, the first level above the surface.  I know, wow.
5986
5987                ELSE
5988                   knext = ko_above_sfc(i)
5989                END IF
5990
5991                !  One more time, make sure the pressure just above the surface is not "too close", this
5992                !  will cause havoc with the higher order interpolators.  In case of a "too close"
5993                !  instance, we toss out the offending level above the surface (NOT the surface one) by simply
5994                !  incrementing the loop counter.  Here, count-1 is the surface level and knext is either
5995                !  the next level up OR it is the level above the prescribed number of eta surfaces.
5996
5997                IF ( ordered_porig(count-1) - porig(i,knext,j) .LT. zap_close_levels ) THEN
5998                   kst = knext+1
5999                   zap = zap + 1
6000                   zap_above = zap_above + 1
6001                ELSE
6002                   kst = knext
6003                END IF
6004
6005                DO ko = kst , generic
6006                   ordered_porig(count) = porig(i,ko,j)
6007                   ordered_forig(count) = forig(i,ko,j)
6008                   count = count + 1
6009                END DO
6010
6011             !  This is easy, the surface is the lowest level, just stick them in, in this order.  OK,
6012             !  there are a couple of subtleties.  We have to check for that special interpolation that
6013             !  skips some input levels so that the surface is used for the lowest few eta levels.  Also,
6014             !  we must make sure that we still do not have levels that are "too close" together.
6015
6016             ELSE
6017
6018                !  Initialize no input levels have yet been removed from consideration.
6019
6020                zap = 0
6021
6022                !  The surface is the lowest level, so it gets set right away to location 1.
6023
6024                ordered_porig(1) = porig(i,1,j)
6025                ordered_forig(1) = forig(i,1,j)
6026
6027                !  We start filling in the array at loc 2, as in just above the level we just stored.
6028
6029                count = 2
6030
6031                !  Are we forcing the interpolator to skip valid input levels so that the
6032                !  surface data is used through more levels?  Essentially as above.
6033
6034                IF ( force_sfc_in_vinterp .GT. 0 ) THEN
6035                   knext = 2
6036                   find_level2: DO ko = 2 , generic
6037                      IF ( porig(i,ko,j) .LE. pnew(i,force_sfc_in_vinterp,j) ) THEN
6038                         knext = ko
6039                         exit find_level2
6040                      ELSE
6041                         zap = zap + 1
6042                         zap_above = zap_above + 1
6043                      END IF
6044                   END DO find_level2
6045                ELSE
6046                   knext = 2
6047                END IF
6048
6049                !  Fill in the data above the surface.  The "knext" index is either the one
6050                !  just above the surface OR it is the index associated with the level that
6051                !  is just above the pressure at this (i,j) of the top eta level that is to
6052                !  be directly impacted with the surface level in interpolation.
6053
6054                DO ko = knext , generic
6055                   IF ( ( ordered_porig(count-1) - porig(i,ko,j) .LT. zap_close_levels ) .AND. &
6056                        ( ko .LT. generic ) ) THEN
6057                      zap = zap + 1
6058                      zap_above = zap_above + 1
6059                      CYCLE
6060                   END IF
6061                   ordered_porig(count) = porig(i,ko,j)
6062                   ordered_forig(count) = forig(i,ko,j)
6063                   count = count + 1
6064                END DO
6065
6066             END IF
6067
6068             !  Now get the column of the "new" pressure data.  So, this one is easy.
6069
6070             DO kn = kstart , kend
6071                ordered_pnew(kn) = pnew(i,kn,j)
6072             END DO
6073
6074             !  How many levels (count) are we shipping to the Lagrange interpolator.
6075
6076             IF      ( ( use_levels_below_ground ) .AND. ( use_surface ) ) THEN
6077
6078                !  Use all levels, including the input surface, and including the pressure
6079                !  levels below ground.  We know to stop when we have reached the top of
6080                !  the input pressure data.
6081
6082                count = 0
6083                find_how_many_1 : DO ko = 1 , generic
6084                   IF ( porig(i,generic,j) .EQ. ordered_porig(ko) ) THEN
6085                      count = count + 1
6086                      EXIT find_how_many_1
6087                   ELSE
6088                      count = count + 1
6089                   END IF
6090                END DO find_how_many_1
6091                kinterp_start = 1
6092                kinterp_end = kinterp_start + count - 1
6093
6094             ELSE IF ( ( use_levels_below_ground ) .AND. ( .NOT. use_surface ) ) THEN
6095
6096                !  Use all levels (excluding the input surface) and including the pressure
6097                !  levels below ground.  We know to stop when we have reached the top of
6098                !  the input pressure data.
6099
6100                count = 0
6101                find_sfc_2 : DO ko = 1 , generic
6102                   IF ( porig(i,1,j) .EQ. ordered_porig(ko) ) THEN
6103                      sfc_level = ko
6104                      EXIT find_sfc_2
6105                   END IF
6106                END DO find_sfc_2
6107
6108                DO ko = sfc_level , generic-1
6109                   ordered_porig(ko) = ordered_porig(ko+1)
6110                   ordered_forig(ko) = ordered_forig(ko+1)
6111                END DO
6112                ordered_porig(generic) = 1.E-5
6113                ordered_forig(generic) = 1.E10
6114
6115                count = 0
6116                find_how_many_2 : DO ko = 1 , generic
6117                   IF ( porig(i,generic,j) .EQ. ordered_porig(ko) ) THEN
6118                      count = count + 1
6119                      EXIT find_how_many_2
6120                   ELSE
6121                      count = count + 1
6122                   END IF
6123                END DO find_how_many_2
6124                kinterp_start = 1
6125                kinterp_end = kinterp_start + count - 1
6126
6127             ELSE IF ( ( .NOT. use_levels_below_ground ) .AND. ( use_surface ) ) THEN
6128
6129                !  Use all levels above the input surface pressure.
6130
6131                kcount = ko_above_sfc(i)-1-zap_below
6132                count = 0
6133                DO ko = 1 , generic
6134                   IF ( porig(i,ko,j) .EQ. ordered_porig(kcount) ) THEN
6135 !  write (6,fmt='(f11.3,f11.3,g11.5)') porig(i,ko,j),ordered_porig(kcount),ordered_forig(kcount)
6136                      kcount = kcount + 1
6137                      count = count + 1
6138                   ELSE
6139 !  write (6,fmt='(f11.3            )') porig(i,ko,j)
6140                   END IF
6141                END DO
6142                kinterp_start = ko_above_sfc(i)-1-zap_below
6143                kinterp_end = kinterp_start + count - 1
6144
6145             END IF
6146
6147             !  If we have additional levels (for example, some arrays have a "level of max winds"
6148             !  or a "level of the tropopause"), we insert them here.
6149
6150             IF ( ( flag_maxw .EQ. 1 ) .AND. ( porig_maxw(i,j) .LE. maxw_above_this_level ) ) then
6151                ok_data = .TRUE.
6152                DO jj = -2, 2
6153                DO ii = -2, 2
6154                   ok_data = ok_data .AND. &
6155                   ( ABS(po_maxwnn(MAX(MIN(i+ii,iend+2,ide-1),istart-2,ids),MAX(MIN(j+jj,jend+2,jde-1),jstart-2,jds))-porig_maxw(i,j)) &
6156                   .LT. maxw_horiz_pres_diff )
6157                END DO
6158                END DO
6159                IF ( ok_data) THEN
6160                   insert_maxw : DO ko = kinterp_start , kinterp_end-1
6161                      IF ( ( ( ordered_porig(ko)-porig_maxw(i,j) ) * ( ordered_porig(ko+1)-porig_maxw(i,j) ) ) .LT. 0 ) THEN
6162                         IF ( ( ABS(ordered_porig(ko  )-porig_maxw(i,j)) .GT. zap_close_extra_levels ) .AND. &
6163                              ( ABS(ordered_porig(ko+1)-porig_maxw(i,j)) .GT. zap_close_extra_levels ) ) THEN
6164                            DO kcount = kinterp_end , ko+1 , -1
6165                               ordered_porig(kcount+1) = ordered_porig(kcount)
6166                               ordered_forig(kcount+1) = ordered_forig(kcount)
6167                            END DO
6168                            ordered_porig(ko+1) = porig_maxw(i,j)
6169                            ordered_forig(ko+1) = fo_maxw(i,j)
6170                            kinterp_end = kinterp_end + 1
6171                            EXIT insert_maxw
6172                         ELSE IF ( ABS(ordered_porig(ko  )-porig_maxw(i,j)) .LE. zap_close_extra_levels ) THEN
6173                            ordered_porig(ko) = porig_maxw(i,j)
6174                            ordered_forig(ko) = fo_maxw(i,j)
6175                            EXIT insert_maxw
6176                         ELSE IF ( ABS(ordered_porig(ko+1)-porig_maxw(i,j)) .LE. zap_close_extra_levels ) THEN
6177                            ordered_porig(ko+1) = porig_maxw(i,j)
6178                            ordered_forig(ko+1) = fo_maxw(i,j)
6179                            EXIT insert_maxw
6180                         END IF
6181                      END IF
6182                   END DO insert_maxw
6183                END IF
6184             END IF
6185
6186             IF ( flag_trop .EQ. 1 ) THEN
6187                ok_data = .TRUE.
6188                DO jj = -2, 2
6189                DO ii = -2, 2
6190                   ok_data = ok_data .AND. &
6191                   ( ABS(po_tropnn(MAX(MIN(i+ii,iend+2,ide-1),istart-2,ids),MAX(MIN(j+jj,jend+2,jde-1),jstart-2,jds))-porig_trop(i,j)) &
6192                   .LT. trop_horiz_pres_diff )
6193                END DO
6194                END DO
6195                IF ( ok_data) THEN
6196                   insert_trop : DO ko = kinterp_start , kinterp_end-1
6197                      IF ( ( ( ordered_porig(ko)-porig_trop(i,j) ) * ( ordered_porig(ko+1)-porig_trop(i,j) ) ) .LT. 0 ) THEN
6198                         IF ( ( ABS(ordered_porig(ko  )-porig_trop(i,j)) .GT. zap_close_extra_levels ) .AND. &
6199                              ( ABS(ordered_porig(ko+1)-porig_trop(i,j)) .GT. zap_close_extra_levels ) ) THEN
6200                            DO kcount = kinterp_end , ko+1 , -1
6201                               ordered_porig(kcount+1) = ordered_porig(kcount)
6202                               ordered_forig(kcount+1) = ordered_forig(kcount)
6203                            END DO
6204                            ordered_porig(ko+1) = porig_trop(i,j)
6205                            ordered_forig(ko+1) = fo_trop(i,j)
6206                            kinterp_end = kinterp_end + 1
6207                            EXIT insert_trop
6208                         ELSE IF ( ABS(ordered_porig(ko  )-porig_trop(i,j)) .LE. zap_close_extra_levels ) THEN
6209                            ordered_porig(ko) = porig_trop(i,j)
6210                            ordered_forig(ko) = fo_trop(i,j)
6211                            EXIT insert_trop
6212                         ELSE IF ( ABS(ordered_porig(ko+1)-porig_trop(i,j)) .LE. zap_close_extra_levels ) THEN
6213                            ordered_porig(ko+1) = porig_trop(i,j)
6214                            ordered_forig(ko+1) = fo_trop(i,j)
6215                            EXIT insert_trop
6216                         END IF
6217                      END IF
6218                   END DO insert_trop
6219                END IF
6220             END IF
6221
6222 #if 0
6223             !  One final check to make sure that the delta pressures are OK.
6224
6225             final_zap_check_count = 0
6226             DO ko = kinterp_start , kinterp_end-1
6227
6228                count_close_by_at_ko = 0
6229                close_by_at_ko : DO
6230
6231                   !  First, is the pressure difference between two neighboring layers too small?
6232
6233                   IF ( ABS(ordered_porig(ko) - ordered_porig(ko+1)) .LT. zap_close_levels ) THEN
6234
6235                      !  Make sure we are vertically located where this difference is meaningful.  For
6236                      !  example, a 5 hPa zap_close_levels makes sense at 850 hPa.  However, a 5 hPa
6237                      !  critical thickness is sill when the top few isobaric levels are 1, 2, 3 hPa.
6238
6239                      IF ( ordered_porig(ko) .GT. zap_close_levels * 10 ) THEN
6240
6241                         !  Now we have a grid point that we should remove.  We pull out the pressure
6242                         !  and field values, then we drop the rest of the array to fill in the
6243                         !  missing spot, we increment our counter of bad values found in this column,
6244                         !  and then we reduce the count of the total number of values in the array.
6245
6246                         DO kn = ko+1 , kinterp_end
6247                            ordered_porig(kn-1) = ordered_porig(kn)
6248                            ordered_forig(kn-1) = ordered_forig(kn)
6249                         END DO
6250                         final_zap_check_count = final_zap_check_count + 1
6251                      END IF
6252                   END IF
6253
6254                   !  Did we pull down another pressure difference into the ko and ko+1 slots that will
6255                   !  cause troubles?  Make sure we don't spend an infinite amount of time in this loop.
6256
6257                   IF ( ( ABS(ordered_porig(ko) - ordered_porig(ko+1)) .GE. zap_close_levels ) .OR. &
6258                        ( ordered_porig(ko) .LE. zap_close_levels * 10 ) ) THEN
6259                      EXIT close_by_at_ko
6260                   ELSE IF ( count_close_by_at_ko .GT. 3 ) THEN
6261                      final_zap_check_count = 99
6262                      EXIT close_by_at_ko
6263                   ELSE
6264                      count_close_by_at_ko = count_close_by_at_ko + 1
6265                      CYCLE close_by_at_ko
6266                   END IF
6267                END DO close_by_at_ko
6268             END DO
6269             IF ( final_zap_check_count .GT. 2 ) THEN
6270                WRITE ( message , * ) 'We are removing too many values: ',final_zap_check_count,' for (i,j) = ',i,j
6271                CALL wrf_error_fatal ( TRIM(message) )
6272             END IF
6273             kinterp_end = kinterp_end - final_zap_check_count
6274 #else
6275             outer : DO ko = kinterp_start , kinterp_end-1
6276                IF ( ( ABS(ordered_porig(ko) - ordered_porig(ko+1)) .LT. MAX(zap_close_levels/10,50.) ) .AND. &
6277                     ( ordered_porig(ko) .GT. zap_close_levels * 10 ) ) THEN
6278                   WRITE ( message , FMT='(a,I2.2,a,F9.2,a,F9.2,a,i4,a,i4,a,a)' ) '*** -> Check your wrfinput_d',id, &
6279                                                                     ' file, you might have input pressure levels too close together (',&
6280                                                                     ordered_porig(ko),' Pa and ', ordered_porig(ko+1), &
6281                                                                     ' Pa) at (',i,',',j,') for variable type ',var_type
6282                      CALL wrf_message ( TRIM(message) )
6283                   EXIT outer
6284                END IF
6285             END DO outer
6286 #endif
6287
6288             !  The polynomials are either in pressure or LOG(pressure).
6289
6290             IF ( interp_type .EQ. 1 ) THEN
6291                CALL lagrange_setup ( var_type , interp_type , &
6292                     ordered_porig(kinterp_start:kinterp_end) , &
6293                     ordered_forig(kinterp_start:kinterp_end) , &
6294                     kinterp_end-kinterp_start+1 , lagrange_order , extrap_type , &
6295                     ordered_pnew(kstart:kend)  , ordered_fnew  , kend-kstart+1 ,i,j)
6296             ELSE
6297                CALL lagrange_setup ( var_type , interp_type , &
6298                 LOG(ordered_porig(kinterp_start:kinterp_end)) , &
6299                     ordered_forig(kinterp_start:kinterp_end) , &
6300                     kinterp_end-kinterp_start+1 , lagrange_order , extrap_type , &
6301                 LOG(ordered_pnew(kstart:kend)) , ordered_fnew  , kend-kstart+1 ,i,j)
6302             END IF
6303
6304             !  Save the computed data.
6305
6306             DO kn = kstart , kend
6307                fnew(i,kn,j) = ordered_fnew(kn)
6308             END DO
6309
6310             !  There may have been a request to have the surface data from the input field
6311             !  to be assigned as to the lowest eta level.  This assumes thin layers (usually
6312             !  the isobaric original field has the surface from 2-m T and RH, and 10-m U and V).
6313
6314             IF ( lowest_lev_from_sfc ) THEN
6315                fnew(i,1,j) = forig(i,1,j)
6316             END IF
6317
6318          END DO
6319
6320       END DO
6321
6322    END SUBROUTINE vert_interp
6323
6324 !---------------------------------------------------------------------
6325
6326    SUBROUTINE lagrange_setup ( var_type , interp_type , all_x , all_y , all_dim , n , extrap_type , &
6327                                target_x , target_y , target_dim ,i,j)
6328
6329       !  We call a Lagrange polynomial interpolator.  The parallel concerns are put off as this
6330       !  is initially set up for vertical use.  The purpose is an input column of pressure (all_x),
6331       !  and the associated pressure level data (all_y).  These are assumed to be sorted (ascending
6332       !  or descending, no matter).  The locations to be interpolated to are the pressures in
6333       !  target_x, probably the new vertical coordinate values.  The field that is output is the
6334       !  target_y, which is defined at the target_x location.  Mostly we expect to be 2nd order
6335       !  overlapping polynomials, with only a single 2nd order method near the top and bottom.
6336       !  When n=1, this is linear; when n=2, this is a second order interpolator.
6337
6338       IMPLICIT NONE
6339
6340       CHARACTER (LEN=1) :: var_type
6341       INTEGER , INTENT(IN) :: interp_type , all_dim , n , extrap_type , target_dim
6342       REAL, DIMENSION(all_dim) , INTENT(IN) :: all_x , all_y
6343       REAL , DIMENSION(target_dim) , INTENT(IN) :: target_x
6344       REAL , DIMENSION(target_dim) , INTENT(OUT) :: target_y
6345
6346 !  cubic spline defs
6347       INTEGER :: K
6348       REAL :: DX, ALPHA, BETA, GAMMA, ETA
6349       REAL , DIMENSION(all_dim) :: P2
6350 !  cubic spline defs
6351
6352       !  Brought in for debug purposes, all of the computations are in a single column.
6353
6354       INTEGER , INTENT(IN) :: i,j
6355
6356       !  Local vars
6357
6358       REAL , DIMENSION(n+1) :: x , y
6359       REAL :: a , b
6360       REAL :: target_y_1 , target_y_2
6361       LOGICAL :: found_loc
6362       INTEGER :: loop , loc_center_left , loc_center_right , ist , iend , target_loop
6363       INTEGER :: vboundb , vboundt
6364
6365       !  Local vars for the problem of extrapolating theta below ground.
6366
6367       REAL :: temp_1 , temp_2 , temp_3 , temp_y
6368       REAL :: depth_of_extrap_in_p , avg_of_extrap_p , temp_extrap_starting_point , dhdp , dh , dt
6369 #ifdef VERT_UNIT
6370       REAL , PARAMETER :: RovCp      = 0.287
6371 #else
6372       REAL , PARAMETER :: RovCp      = rcp
6373 #endif
6374       REAL , PARAMETER :: CRC_const1 = 11880.516      ! m
6375       REAL , PARAMETER :: CRC_const2 =     0.1902632  !
6376       REAL , PARAMETER :: CRC_const3 =     0.0065     ! K/km
6377       REAL, DIMENSION(all_dim) :: all_x_full
6378       REAL , DIMENSION(target_dim) :: target_x_full
6379
6380       IF ( all_dim .LT. n+1 ) THEN
6381 print *,'all_dim = ',all_dim
6382 print *,'order = ',n
6383 print *,'i,j = ',i,j
6384 print *,'p array = ',all_x
6385 print *,'f array = ',all_y
6386 print *,'p target= ',target_x
6387          CALL wrf_message ( 0 , 'Troubles, the interpolating order is too large for this few input values' )
6388          CALL wrf_message ( 0 , 'This is usually caused by bad pressures' )
6389          CALL wrf_message ( 0 , 'At this (i,j), look at the input value of pressure from metgrid' )
6390          CALL wrf_message ( 0 , 'The surface pressure and the sea-level pressure should be reviewed, also from metgrid' )
6391          CALL wrf_message ( 0 , 'Finally, ridiculous values of moisture can mess up the vertical pressures, especially aloft' )
6392          CALL wrf_message ( 0 , 'The variable type is ' // var_type // '. This is not a unique identifer, but a type of field' )
6393          CALL wrf_message ( 0 , 'Check to see if all time periods with this data fail, or just this one' )
6394          CALL wrf_error_fatal ( 'This vertical interpolation failure is more typically associated with untested data sources to ungrib' )
6395       END IF
6396
6397       IF ( n .LT. 1 ) THEN
6398          CALL wrf_error_fatal ( 'pal, linear is about as low as we go' )
6399       END IF
6400
6401       !  We can pinch in the area of the higher order interpolation with vbound.  If
6402       !  vbound = 0, no pinching.  If vbound = m, then we make the lower "m" and upper
6403       !  "m" eta levels use a linear interpolation.
6404
6405       vboundb = 4
6406       vboundt = 0
6407
6408       !  Loop over the list of target x and y values.
6409
6410       DO target_loop = 1 , target_dim
6411
6412          !  Find the two trapping x values, and keep the indices.
6413
6414          found_loc = .FALSE.
6415          find_trap : DO loop = 1 , all_dim -1
6416             a = target_x(target_loop) - all_x(loop)
6417             b = target_x(target_loop) - all_x(loop+1)
6418             IF ( a*b .LE. 0.0 ) THEN
6419                loc_center_left  = loop
6420                loc_center_right = loop+1
6421                found_loc = .TRUE.
6422                EXIT find_trap
6423             END IF
6424          END DO find_trap
6425
6426          IF ( ( .NOT. found_loc ) .AND. ( target_x(target_loop) .GT. all_x(1) ) ) THEN
6427
6428             !  Get full pressure back so that our extrpolations make sense.
6429
6430             IF ( interp_type .EQ. 1 ) THEN
6431                all_x_full    =       all_x
6432                target_x_full =       target_x
6433             ELSE
6434                all_x_full    = EXP ( all_x )
6435                target_x_full = EXP ( target_x )
6436             END IF
6437             !  Isothermal extrapolation.
6438
6439             IF      ( ( extrap_type .EQ. 1 ) .AND. ( var_type .EQ. 'T' ) ) THEN
6440
6441                temp_1 = all_y(1) * ( all_x_full(1) / 100000. ) ** RovCp
6442                target_y(target_loop) = temp_1 * ( 100000. / target_x_full(target_loop) ) ** RovCp
6443
6444             !  Standard atmosphere -6.5 K/km lapse rate for the extrapolation.
6445
6446             ELSE IF ( ( extrap_type .EQ. 2 ) .AND. ( var_type .EQ. 'T' ) ) THEN
6447
6448                depth_of_extrap_in_p = target_x_full(target_loop) - all_x_full(1)
6449                avg_of_extrap_p = ( target_x_full(target_loop) + all_x_full(1) ) * 0.5
6450                temp_extrap_starting_point = all_y(1) * ( all_x_full(1) / 100000. ) ** RovCp
6451                dhdp = CRC_const1 * CRC_const2 * ( avg_of_extrap_p / 100. ) ** ( CRC_const2 - 1. )
6452                dh = dhdp * ( depth_of_extrap_in_p / 100. )
6453                dt = dh * CRC_const3
6454                target_y(target_loop) = ( temp_extrap_starting_point + dt ) * ( 100000. / target_x_full(target_loop) ) ** RovCp
6455
6456             !  Adiabatic extrapolation for theta.
6457
6458             ELSE IF ( ( extrap_type .EQ. 3 ) .AND. ( var_type .EQ. 'T' ) ) THEN
6459
6460                target_y(target_loop) = all_y(1)
6461
6462
6463             !  Wild extrapolation for non-temperature vars.
6464
6465             ELSE IF ( extrap_type .EQ. 1 ) THEN
6466
6467                target_y(target_loop) = ( all_y(2) * ( target_x(target_loop) - all_x(3) ) + &
6468                                          all_y(3) * ( all_x(2) - target_x(target_loop) ) ) / &
6469                                        ( all_x(2) - all_x(3) )
6470
6471             !  Use a constant value below ground.
6472
6473             ELSE IF ( extrap_type .EQ. 2 ) THEN
6474
6475                target_y(target_loop) = all_y(1)
6476
6477             ELSE IF ( extrap_type .EQ. 3 ) THEN
6478                CALL wrf_error_fatal ( 'You are not allowed to use extrap_option #3 for any var except for theta.' )
6479
6480             END IF
6481             CYCLE
6482          ELSE IF ( .NOT. found_loc ) THEN
6483             print *,'i,j = ',i,j
6484             print *,'target pressure and value = ',target_x(target_loop),target_y(target_loop)
6485             DO loop = 1 , all_dim
6486                print *,'column of pressure and value = ',all_x(loop),all_y(loop)
6487             END DO
6488             CALL wrf_error_fatal ( 'troubles, could not find trapping x locations' )
6489          END IF
6490
6491          !  Even or odd order?  We can put the value in the middle if this is
6492          !  an odd order interpolator.  For the even guys, we'll do it twice
6493          !  and shift the range one index, then get an average.
6494
6495          IF ( n .EQ. 9 ) THEN
6496             CALL cubic_spline (all_dim-1, all_x, all_y, P2)
6497 !
6498 ! Find the value of function f(x)
6499 !
6500           DX = all_x(loc_center_right) - all_x(loc_center_left)
6501           ALPHA = P2(loc_center_right)/(6*DX)
6502           BETA = -P2(loc_center_left)/(6*DX)
6503           GAMMA = all_y(loc_center_right)/DX - DX*P2(loc_center_right)/6
6504           ETA = DX*P2(loc_center_left)/6 - all_y(loc_center_left)/DX
6505           target_y(target_loop) = ALPHA*(target_x(target_loop)-all_x(loc_center_left))*(target_x(target_loop)-all_x(loc_center_left)) &
6506                                   *(target_x(target_loop)-all_x(loc_center_left)) &
6507                      +BETA*(target_x(target_loop)-all_x(loc_center_right))*(target_x(target_loop)-all_x(loc_center_right)) &
6508                                   *(target_x(target_loop)-all_x(loc_center_right)) &
6509                      +GAMMA*(target_x(target_loop)-all_x(loc_center_left)) &
6510                      +ETA*(target_x(target_loop)-all_x(loc_center_right))
6511
6512          ELSE IF ( MOD(n,2) .NE. 0 ) THEN
6513             IF ( ( loc_center_left -(((n+1)/2)-1) .GE.       1 ) .AND. &
6514                  ( loc_center_right+(((n+1)/2)-1) .LE. all_dim ) ) THEN
6515                ist  = loc_center_left -(((n+1)/2)-1)
6516                iend = ist + n
6517                CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y(target_loop) )
6518             ELSE
6519                IF ( .NOT. found_loc ) THEN
6520                   CALL wrf_error_fatal ( 'I doubt this will happen, I will only do 2nd order for now' )
6521                END IF
6522             END IF
6523
6524          ELSE IF ( ( MOD(n,2) .EQ. 0 ) .AND. &
6525                    ( ( target_loop .GE. 1 + vboundb ) .AND. ( target_loop .LE. target_dim - vboundt ) ) ) THEN
6526             IF      ( ( loc_center_left -(((n  )/2)-1) .GE.       1 ) .AND. &
6527                       ( loc_center_right+(((n  )/2)  ) .LE. all_dim ) .AND. &
6528                       ( loc_center_left -(((n  )/2)  ) .GE.       1 ) .AND. &
6529                       ( loc_center_right+(((n  )/2)-1) .LE. all_dim ) ) THEN
6530                ist  = loc_center_left -(((n  )/2)-1)
6531                iend = ist + n
6532                CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y_1              )
6533                ist  = loc_center_left -(((n  )/2)  )
6534                iend = ist + n
6535                CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y_2              )
6536                target_y(target_loop) = ( target_y_1 + target_y_2 ) * 0.5
6537
6538             ELSE IF ( ( loc_center_left -(((n  )/2)-1) .GE.       1 ) .AND. &
6539                       ( loc_center_right+(((n  )/2)  ) .LE. all_dim ) ) THEN
6540                ist  = loc_center_left -(((n  )/2)-1)
6541                iend = ist + n
6542                CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y(target_loop)   )
6543             ELSE IF ( ( loc_center_left -(((n  )/2)  ) .GE.       1 ) .AND. &
6544                       ( loc_center_right+(((n  )/2)-1) .LE. all_dim ) ) THEN
6545                ist  = loc_center_left -(((n  )/2)  )
6546                iend = ist + n
6547                CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y(target_loop)   )
6548             ELSE
6549                CALL wrf_error_fatal ( 'unauthorized area, you should not be here' )
6550             END IF
6551
6552          ELSE IF ( MOD(n,2) .EQ. 0 ) THEN
6553                ist  = loc_center_left
6554                iend = loc_center_right
6555                CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , 1 , target_x(target_loop) , target_y(target_loop) )
6556
6557          END IF
6558
6559       END DO
6560
6561    END SUBROUTINE lagrange_setup
6562
6563 !---------------------------------------------------------------------
6564
6565 ! cubic spline routines
6566
6567       SUBROUTINE cubic_spline (N, XI, FI, P2)
6568       !
6569       ! Function to carry out the cubic-spline approximation
6570       ! with the second-order derivatives returned.
6571       !
6572       INTEGER :: I
6573       INTEGER, INTENT (IN) :: N
6574       REAL, INTENT (IN), DIMENSION (N+1):: XI, FI
6575       REAL, INTENT (OUT), DIMENSION (N+1):: P2
6576       REAL, DIMENSION (N):: G, H
6577       REAL, DIMENSION (N-1):: D, B, C
6578 !
6579 ! Assign the intervals and function differences
6580 !
6581   DO I = 1, N
6582     H(I) = XI(I+1) - XI(I)
6583     G(I) = FI(I+1) - FI(I)
6584   END DO
6585 !
6586 ! Evaluate the coefficient matrix elements
6587   DO I = 1, N-1
6588     D(I) = 2*(H(I+1)+H(I))
6589     B(I) = 6*(G(I+1)/H(I+1)-G(I)/H(I))
6590     C(I) = H(I+1)
6591   END DO
6592 !
6593 ! Obtain the second-order derivatives
6594 !
6595   CALL TRIDIAGONAL_LINEAR_EQ (N-1, D, C, C, B, G)
6596   P2(1) = 0
6597   P2(N+1) = 0
6598   DO I = 2, N
6599     P2(I) = G(I-1)
6600   END DO
6601
6602 END SUBROUTINE cubic_spline
6603
6604 !---------------------------------------------------------------------
6605
6606     SUBROUTINE TRIDIAGONAL_LINEAR_EQ (L, D, E, C, B, Z)
6607 !
6608 ! Function to solve the tridiagonal linear equation set.
6609 !
6610   INTEGER, INTENT (IN) :: L
6611   INTEGER :: I
6612   REAL, INTENT (IN), DIMENSION (L):: D, E, C, B
6613   REAL, INTENT (OUT), DIMENSION (L):: Z
6614   REAL, DIMENSION (L):: Y, W
6615   REAL, DIMENSION (L-1):: V, T
6616 !
6617 ! Evaluate the elements in the LU decomposition
6618 !
6619   W(1) = D(1)
6620   V(1)  = C(1)
6621   T(1)  = E(1)/W(1)
6622   DO I = 2, L - 1
6623     W(I) = D(I)-V(I-1)*T(I-1)
6624     V(I) = C(I)
6625     T(I) = E(I)/W(I)
6626   END DO
6627   W(L) = D(L)-V(L-1)*T(L-1)
6628 !
6629 ! Forward substitution to obtain y
6630 !
6631   Y(1) = B(1)/W(1)
6632   DO I = 2, L
6633     Y(I) = (B(I)-V(I-1)*Y(I-1))/W(I)
6634   END DO
6635 !
6636 ! Backward substitution to obtain z
6637   Z(L) = Y(L)
6638   DO I = L-1, 1, -1
6639     Z(I) = Y(I) - T(I)*Z(I+1)
6640   END DO
6641
6642 END SUBROUTINE TRIDIAGONAL_LINEAR_EQ
6643
6644 ! end cubic spline routines
6645
6646 !---------------------------------------------------------------------
6647
6648    SUBROUTINE lagrange_interp ( x , y , n , target_x , target_y )
6649
6650       !  Interpolation using Lagrange polynomials.
6651       !  P(x) = f(x0)Ln0(x) + ... + f(xn)Lnn(x)
6652       !  where Lnk(x) = (x -x0)(x -x1)...(x -xk-1)(x -xk+1)...(x -xn)
6653       !                 ---------------------------------------------
6654       !                 (xk-x0)(xk-x1)...(xk-xk-1)(xk-xk+1)...(xk-xn)
6655
6656       IMPLICIT NONE
6657
6658       INTEGER , INTENT(IN) :: n
6659       REAL , DIMENSION(0:n) , INTENT(IN) :: x , y
6660       REAL , INTENT(IN) :: target_x
6661
6662       REAL , INTENT(OUT) :: target_y
6663
6664       !  Local vars
6665
6666       INTEGER :: i , k
6667       REAL :: numer , denom , Px
6668       REAL , DIMENSION(0:n) :: Ln
6669
6670       Px = 0.
6671       DO i = 0 , n
6672          numer = 1.
6673          denom = 1.
6674          DO k = 0 , n
6675             IF ( k .EQ. i ) CYCLE
6676             numer = numer * ( target_x  - x(k) )
6677             denom = denom * ( x(i)  - x(k) )
6678          END DO
6679          IF ( denom .NE. 0. ) THEN
6680             Ln(i) = y(i) * numer / denom
6681             Px = Px + Ln(i)
6682          ENDIF
6683       END DO
6684       target_y = Px
6685
6686    END SUBROUTINE lagrange_interp
6687
6688 #ifndef VERT_UNIT
6689 !---------------------------------------------------------------------
6690
6691    SUBROUTINE p_dry ( mu0 , eta , pdht , pdry , full_levs , &
6692                              c3f , c3h , c4f , c4h ,             &
6693                              ids , ide , jds , jde , kds , kde , &
6694                              ims , ime , jms , jme , kms , kme , &
6695                              its , ite , jts , jte , kts , kte )
6696
6697    !  Compute reference pressure and the reference mu.
6698
6699       IMPLICIT NONE
6700
6701       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
6702                                      ims , ime , jms , jme , kms , kme , &
6703                                      its , ite , jts , jte , kts , kte
6704
6705       LOGICAL :: full_levs
6706
6707       REAL , DIMENSION(ims:ime,        jms:jme) , INTENT(IN)     :: mu0
6708       REAL , DIMENSION(        kms:kme        ) , INTENT(IN)     :: eta
6709       REAL , DIMENSION(        kms:kme        ) , INTENT(IN)     :: c3f , c3h , c4f , c4h
6710       REAL                                                       :: pdht
6711       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT)    :: pdry
6712
6713       !  Local vars
6714
6715       INTEGER :: i , j , k
6716       REAL , DIMENSION(        kms:kme        )                  :: eta_h
6717
6718       IF ( full_levs ) THEN
6719          DO j = jts , MIN ( jde-1 , jte )
6720             DO k = kts , kte
6721                DO i = its , MIN (ide-1 , ite )
6722                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6723                      pdry(i,k,j) = c3f(k) * MU0(i,j) + c4f(k) + pdht
6724                END DO
6725             END DO
6726          END DO
6727       ELSE
6728          DO k = kts , kte-1
6729             eta_h(k) = ( eta(k) + eta(k+1) ) * 0.5
6730          END DO
6731          DO j = jts , MIN ( jde-1 , jte )
6732             DO k = kts , kte-1
6733                DO i = its , MIN (ide-1 , ite )
6734                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6735                      pdry(i,k,j) = c3h(k) * MU0(i,j) + c4h(k) + pdht
6736                END DO
6737             END DO
6738          END DO
6739       END IF
6740
6741    END SUBROUTINE p_dry
6742
6743 !---------------------------------------------------------------------
6744
6745    SUBROUTINE p_dts ( pdts , intq , psfc , p_top , &
6746                       ids , ide , jds , jde , kds , kde , &
6747                       ims , ime , jms , jme , kms , kme , &
6748                       its , ite , jts , jte , kts , kte )
6749
6750    !  Compute difference between the dry, total surface pressure and the top pressure.
6751
6752       IMPLICIT NONE
6753
6754       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
6755                                      ims , ime , jms , jme , kms , kme , &
6756                                      its , ite , jts , jte , kts , kte
6757
6758       REAL , INTENT(IN) :: p_top
6759       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN)     :: psfc
6760       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN)     :: intq
6761       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(OUT)    :: pdts
6762
6763       !  Local vars
6764
6765       INTEGER :: i , j , k
6766
6767       DO j = jts , MIN ( jde-1 , jte )
6768          DO i = its , MIN (ide-1 , ite )
6769             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6770             pdts(i,j) = psfc(i,j) - intq(i,j) - p_top
6771          END DO
6772       END DO
6773
6774    END SUBROUTINE p_dts
6775
6776 !---------------------------------------------------------------------
6777
6778    SUBROUTINE p_dhs ( pdhs , ht , p0 , t0 , a , &
6779                       ids , ide , jds , jde , kds , kde , &
6780                       ims , ime , jms , jme , kms , kme , &
6781                       its , ite , jts , jte , kts , kte )
6782
6783    !  Compute dry, hydrostatic surface pressure.
6784
6785       IMPLICIT NONE
6786
6787       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
6788                                      ims , ime , jms , jme , kms , kme , &
6789                                      its , ite , jts , jte , kts , kte
6790
6791       REAL , DIMENSION(ims:ime,        jms:jme) , INTENT(IN)     :: ht
6792       REAL , DIMENSION(ims:ime,        jms:jme) , INTENT(OUT)    :: pdhs
6793
6794       REAL , INTENT(IN) :: p0 , t0 , a
6795
6796       !  Local vars
6797
6798       INTEGER :: i , j , k
6799
6800       REAL , PARAMETER :: Rd = r_d
6801
6802       DO j = jts , MIN ( jde-1 , jte )
6803          DO i = its , MIN (ide-1 , ite )
6804             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6805             pdhs(i,j) = p0 * EXP ( -t0/a + SQRT ( (t0/a)**2 - 2. * g * ht(i,j)/(a * Rd) ) )
6806          END DO
6807       END DO
6808
6809    END SUBROUTINE p_dhs
6810
6811 !---------------------------------------------------------------------
6812
6813    SUBROUTINE find_p_top ( p , p_top , &
6814                            ids , ide , jds , jde , kds , kde , &
6815                            ims , ime , jms , jme , kms , kme , &
6816                            its , ite , jts , jte , kts , kte )
6817
6818    !  Find the largest pressure in the top level.  This is our p_top.  We are
6819    !  assuming that the top level is the location where the pressure is a minimum
6820    !  for each column.  In cases where the top surface is not isobaric, a
6821    !  communicated value must be shared in the calling routine.  Also in cases
6822    !  where the top surface is not isobaric, care must be taken that the new
6823    !  maximum pressure is not greater than the previous value.  This test is
6824    !  also handled in the calling routine.
6825
6826       IMPLICIT NONE
6827
6828       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
6829                                      ims , ime , jms , jme , kms , kme , &
6830                                      its , ite , jts , jte , kts , kte
6831
6832       REAL :: p_top
6833       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p
6834
6835       !  Local vars
6836
6837       INTEGER :: i , j , k, min_lev
6838
6839       i = its
6840       j = jts
6841       p_top = p(i,2,j)
6842       min_lev = 2
6843       DO k = 2 , kte
6844          IF ( p_top .GT. p(i,k,j) ) THEN
6845             p_top = p(i,k,j)
6846             min_lev = k
6847          END IF
6848       END DO
6849
6850       k = min_lev
6851       p_top = p(its,k,jts)
6852       DO j = jts , MIN ( jde-1 , jte )
6853          DO i = its , MIN (ide-1 , ite )
6854             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6855             p_top = MAX ( p_top , p(i,k,j) )
6856          END DO
6857       END DO
6858
6859    END SUBROUTINE find_p_top
6860
6861 !---------------------------------------------------------------------
6862
6863    SUBROUTINE t_to_theta ( t , p , p00 , &
6864                       ids , ide , jds , jde , kds , kde , &
6865                       ims , ime , jms , jme , kms , kme , &
6866                       its , ite , jts , jte , kts , kte )
6867
6868    !  Compute potential temperature from temperature and pressure.
6869
6870       IMPLICIT NONE
6871
6872       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
6873                                      ims , ime , jms , jme , kms , kme , &
6874                                      its , ite , jts , jte , kts , kte
6875
6876       REAL , INTENT(IN) :: p00
6877       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN)     :: p
6878       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT)  :: t
6879
6880       !  Local vars
6881
6882       INTEGER :: i , j , k
6883
6884       REAL , PARAMETER :: Rd = r_d
6885
6886       DO j = jts , MIN ( jde-1 , jte )
6887          DO k = kts , kte
6888             DO i = its , MIN (ide-1 , ite )
6889                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6890                t(i,k,j) = t(i,k,j) * ( p00 / p(i,k,j) ) ** (Rd / Cp)
6891             END DO
6892          END DO
6893       END DO
6894
6895    END SUBROUTINE t_to_theta
6896
6897
6898 !---------------------------------------------------------------------
6899
6900    SUBROUTINE theta_to_t ( t , p , p00 , &
6901                       ids , ide , jds , jde , kds , kde , &
6902                       ims , ime , jms , jme , kms , kme , &
6903                       its , ite , jts , jte , kts , kte )
6904
6905    !  Compute temperature from potential temp and pressure.
6906
6907       IMPLICIT NONE
6908
6909       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
6910                                      ims , ime , jms , jme , kms , kme , &
6911                                      its , ite , jts , jte , kts , kte
6912
6913       REAL , INTENT(IN) :: p00
6914       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN)     :: p
6915       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT)  :: t
6916
6917       !  Local vars
6918
6919       INTEGER :: i , j , k
6920
6921       REAL , PARAMETER :: Rd = r_d
6922       CHARACTER (LEN=80) :: mess
6923
6924       DO j = jts , MIN ( jde-1 , jte )
6925          DO k = kts , kte-1
6926             DO i = its , MIN (ide-1 , ite )
6927              IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6928              if ( p(i,k,j) .NE. 0. ) then
6929                t(i,k,j) = t(i,k,j) / ( ( p00 / p(i,k,j) ) ** (Rd / Cp) )
6930              else
6931                WRITE(mess,*) 'Troubles in theta_to_t'
6932                CALL wrf_debug(0,mess)
6933                WRITE(mess,*) "i,j,k = ", i,j,k
6934                CALL wrf_debug(0,mess)
6935                WRITE(mess,*) "p(i,k,j) = ", p(i,k,j)
6936                CALL wrf_debug(0,mess)
6937                WRITE(mess,*) "t(i,k,j) = ", t(i,k,j)
6938                CALL wrf_debug(0,mess)
6939              endif
6940             END DO
6941          END DO
6942       END DO
6943
6944    END SUBROUTINE theta_to_t
6945
6946 !---------------------------------------------------------------------
6947
6948    SUBROUTINE integ_moist ( q_in , p_in , pd_out , t_in , ght_in , intq , &
6949                             ids , ide , jds , jde , kds , kde , &
6950                             ims , ime , jms , jme , kms , kme , &
6951                             its , ite , jts , jte , kts , kte )
6952
6953    !  Integrate the moisture field vertically.  Mostly used to get the total
6954    !  vapor pressure, which can be subtracted from the total pressure to get
6955    !  the dry pressure.
6956
6957       IMPLICIT NONE
6958
6959       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
6960                                      ims , ime , jms , jme , kms , kme , &
6961                                      its , ite , jts , jte , kts , kte
6962
6963       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN)     :: q_in , p_in , t_in , ght_in
6964       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT)    :: pd_out
6965       REAL , DIMENSION(ims:ime,        jms:jme) , INTENT(OUT)    :: intq
6966
6967       !  Local vars
6968
6969       INTEGER :: i , j , k
6970       INTEGER , DIMENSION(ims:ime) :: level_above_sfc
6971       REAL , DIMENSION(ims:ime,jms:jme) :: psfc , tsfc , qsfc, zsfc
6972       REAL , DIMENSION(ims:ime,kms:kme) :: q , p , t , ght, pd
6973
6974       REAL :: rhobar , qbar , dz
6975       REAL :: p1 , p2 , t1 , t2 , q1 , q2 , z1, z2
6976
6977       LOGICAL :: upside_down
6978       LOGICAL :: already_assigned_upside_down
6979
6980       REAL , PARAMETER :: Rd = r_d
6981
6982       !  Is the data upside down?
6983
6984
6985       already_assigned_upside_down = .FALSE.
6986       find_valid : DO j = jts , MIN ( jde-1 , jte )
6987          DO i = its , MIN (ide-1 , ite )
6988             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6989             IF ( p_in(i,kts+1,j) .LT. p_in(i,kte,j) ) THEN
6990                upside_down = .TRUE.
6991                already_assigned_upside_down = .TRUE.
6992             ELSE
6993                upside_down = .FALSE.
6994                already_assigned_upside_down = .TRUE.
6995             END IF
6996             EXIT find_valid
6997          END DO
6998       END DO find_valid
6999
7000       IF ( .NOT. already_assigned_upside_down ) THEN
7001          upside_down = .FALSE.
7002       END IF
7003
7004       !  Get a surface value, always the first level of a 3d field.
7005
7006       DO j = jts , MIN ( jde-1 , jte )
7007          DO i = its , MIN (ide-1 , ite )
7008             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7009             psfc(i,j) = p_in(i,kts,j)
7010             tsfc(i,j) = t_in(i,kts,j)
7011             qsfc(i,j) = q_in(i,kts,j)
7012             zsfc(i,j) = ght_in(i,kts,j)
7013          END DO
7014       END DO
7015
7016       DO j = jts , MIN ( jde-1 , jte )
7017
7018          !  Initialize the integrated quantity of moisture to zero.
7019
7020          DO i = its , MIN (ide-1 , ite )
7021             intq(i,j) = 0.
7022          END DO
7023
7024          IF ( upside_down ) THEN
7025             DO i = its , MIN (ide-1 , ite )
7026                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7027                p(i,kts) = p_in(i,kts,j)
7028                t(i,kts) = t_in(i,kts,j)
7029                q(i,kts) = q_in(i,kts,j)
7030                ght(i,kts) = ght_in(i,kts,j)
7031                DO k = kts+1,kte
7032                   p(i,k) = p_in(i,kte+2-k,j)
7033                   t(i,k) = t_in(i,kte+2-k,j)
7034                   q(i,k) = q_in(i,kte+2-k,j)
7035                   ght(i,k) = ght_in(i,kte+2-k,j)
7036                END DO
7037             END DO
7038          ELSE
7039             DO i = its , MIN (ide-1 , ite )
7040                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7041                DO k = kts,kte
7042                   p(i,k) = p_in(i,k      ,j)
7043                   t(i,k) = t_in(i,k      ,j)
7044                   q(i,k) = q_in(i,k      ,j)
7045                   ght(i,k) = ght_in(i,k      ,j)
7046                END DO
7047             END DO
7048          END IF
7049
7050          !  Find the first level above the ground.  If all of the levels are above ground, such as
7051          !  a terrain following lower coordinate, then the first level above ground is index #2.
7052
7053          DO i = its , MIN (ide-1 , ite )
7054             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7055             level_above_sfc(i) = -1
7056             IF ( p(i,kts+1) .LT. psfc(i,j) ) THEN
7057                level_above_sfc(i) = kts+1
7058             ELSE
7059                find_k : DO k = kts+1,kte-1
7060                   IF ( ( p(i,k  )-psfc(i,j) .GE. 0. ) .AND. &
7061                        ( p(i,k+1)-psfc(i,j) .LT. 0. ) ) THEN
7062                      level_above_sfc(i) = k+1
7063                      EXIT find_k
7064                   END IF
7065                END DO find_k
7066                IF ( level_above_sfc(i) .EQ. -1 ) THEN
7067 print *,'i,j = ',i,j
7068 print *,'p = ',p(i,:)
7069 print *,'p sfc = ',psfc(i,j)
7070                   CALL wrf_error_fatal ( 'Could not find level above ground')
7071                END IF
7072             END IF
7073          END DO
7074
7075          DO i = its , MIN (ide-1 , ite )
7076             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7077
7078             !  Account for the moisture above the ground.
7079
7080             pd(i,kte) = p(i,kte)
7081             DO k = kte-1,level_above_sfc(i),-1
7082                   rhobar = ( p(i,k  ) / ( Rd * t(i,k  ) ) + &
7083                              p(i,k+1) / ( Rd * t(i,k+1) ) ) * 0.5
7084                   qbar   = ( q(i,k  ) + q(i,k+1) ) * 0.5
7085                   dz     = ght(i,k+1) - ght(i,k)
7086                   intq(i,j) = intq(i,j) + g * qbar * rhobar / (1. + qbar) * dz
7087                   pd(i,k) = p(i,k) - intq(i,j)
7088             END DO
7089
7090             !  Account for the moisture between the surface and the first level up.
7091
7092             IF ( ( p(i,level_above_sfc(i)-1)-psfc(i,j) .GE. 0. ) .AND. &
7093                  ( p(i,level_above_sfc(i)  )-psfc(i,j) .LT. 0. ) .AND. &
7094                  ( level_above_sfc(i) .GT. kts ) ) THEN
7095                p1 = psfc(i,j)
7096                p2 = p(i,level_above_sfc(i))
7097                t1 = tsfc(i,j)
7098                t2 = t(i,level_above_sfc(i))
7099                q1 = qsfc(i,j)
7100                q2 = q(i,level_above_sfc(i))
7101                z1 = zsfc(i,j)
7102                z2 = ght(i,level_above_sfc(i))
7103                rhobar = ( p1 / ( Rd * t1 ) + &
7104                           p2 / ( Rd * t2 ) ) * 0.5
7105                qbar   = ( q1 + q2 ) * 0.5
7106                dz     = z2 - z1
7107                IF ( dz .GT. 0.1 ) THEN
7108                   intq(i,j) = intq(i,j) + g * qbar * rhobar / (1. + qbar) * dz
7109                END IF
7110
7111                !  Fix the underground values.
7112
7113                DO k = level_above_sfc(i)-1,kts+1,-1
7114                   pd(i,k) = p(i,k) - intq(i,j)
7115                END DO
7116             END IF
7117             pd(i,kts) = psfc(i,j) - intq(i,j)
7118
7119          END DO
7120
7121          IF ( upside_down ) THEN
7122             DO i = its , MIN (ide-1 , ite )
7123                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7124                pd_out(i,kts,j) = pd(i,kts)
7125                DO k = kts+1,kte
7126                   pd_out(i,kte+2-k,j) = pd(i,k)
7127                END DO
7128             END DO
7129          ELSE
7130             DO i = its , MIN (ide-1 , ite )
7131                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7132                DO k = kts,kte
7133                   pd_out(i,k,j) = pd(i,k)
7134                END DO
7135             END DO
7136          END IF
7137
7138       END DO
7139
7140    END SUBROUTINE integ_moist
7141
7142 !---------------------------------------------------------------------
7143
7144    SUBROUTINE rh_to_mxrat2(rh, t, p, q , wrt_liquid , &
7145                            qv_max_p_safe , &
7146                            qv_max_flag , qv_max_value , &
7147                            qv_min_p_safe , &
7148                            qv_min_flag , qv_min_value , &
7149                            ids , ide , jds , jde , kds , kde , &
7150                            ims , ime , jms , jme , kms , kme , &
7151                            its , ite , jts , jte , kts , kte )
7152
7153       !  This subroutine computes mixing ratio (q, kg/kg) from basic variables
7154       !  pressure (p, Pa), temperature (t, K) and relative humidity (rh, 0-100%).
7155       !  Phase transition, liquid water to ice, occurs over (0,-23) temperature range (Celcius).
7156       !  Formulation used here is based on:
7157       !  WMO, General meteorological standards and recommended practices,
7158       !   Appendix A, WMO Technical Regulations, WMO-No. 49, corrigendum,
7159       !   August 2000.    --TKW 03/30/2011
7160
7161       IMPLICIT NONE
7162
7163       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
7164                                      ims , ime , jms , jme , kms , kme , &
7165                                      its , ite , jts , jte , kts , kte
7166
7167       LOGICAL , INTENT(IN)        :: wrt_liquid
7168
7169       REAL , INTENT(IN)           :: qv_max_p_safe , qv_max_flag , qv_max_value
7170       REAL , INTENT(IN)           :: qv_min_p_safe , qv_min_flag , qv_min_value
7171
7172       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN)     :: p , t
7173       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT)  :: rh
7174       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT)    :: q
7175
7176       !  Local vars
7177
7178       REAL,         PARAMETER     :: T0K = 273.16
7179       REAL,         PARAMETER     :: Tice = T0K - 23.0
7180
7181       REAL,         PARAMETER     :: cfe = 1.0/(23.0*23.0)
7182       REAL,         PARAMETER     :: eps = 0.622
7183
7184       ! Coefficients for esat over liquid water
7185       REAL,         PARAMETER     :: cw1 = 10.79574
7186       REAL,         PARAMETER     :: cw2 = -5.02800
7187       REAL,         PARAMETER     :: cw3 = 1.50475E-4
7188       REAL,         PARAMETER     :: cw4 = 0.42873E-3
7189       REAL,         PARAMETER     :: cw5 = 0.78614
7190
7191       ! Coefficients for esat over ice
7192       REAL,         PARAMETER     :: ci1 = -9.09685
7193       REAL,         PARAMETER     :: ci2 = -3.56654
7194       REAL,         PARAMETER     :: ci3 = 0.87682
7195       REAL,         PARAMETER     :: ci4 = 0.78614
7196
7197       REAL,         PARAMETER     :: Tn = 273.16
7198
7199       ! 1 ppm is a reasonable estimate for minimum QV even for stratospheric altitudes
7200       REAL,         PARAMETER     :: QV_MIN = 1.e-6
7201
7202       ! Maximum allowed QV is computed under the extreme condition:
7203       !            Saturated at 40 degree in Celcius and 1000 hPa
7204       REAL,         PARAMETER     :: QV_MAX = 0.045
7205
7206       ! Need to constrain WVP in the stratosphere where pressure
7207       ! is low but tempearure is hot (warm)
7208       ! Maximum ratio of e/p, = q/(0.622+q)
7209       REAL,         PARAMETER     :: EP_MAX = QV_MAX/(eps+QV_MAX)
7210
7211       INTEGER                     :: i , j , k
7212
7213       REAL                        :: ew , q1 , t1
7214       REAL                        :: ta, tb, pw3, pw4, pwr
7215       REAL                        :: es, esw, esi, wvp, pmb, wvpmax
7216
7217       DO j = jts , MIN ( jde-1 , jte )
7218          DO k = kts , kte
7219             DO i = its , MIN (ide-1 , ite )
7220                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7221                rh(i,k,j) = MIN ( MAX ( rh(i,k,j) ,  0. ) , 100. )
7222             END DO
7223          END DO
7224       END DO
7225
7226       IF ( wrt_liquid ) THEN
7227          DO j = jts , MIN ( jde-1 , jte )
7228             DO k = kts , kte
7229                DO i = its , MIN (ide-1 , ite )
7230                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7231                   Ta=Tn/T(i,k,j)
7232                   Tb=T(i,k,j)/Tn
7233                   pw3 = -8.2969*(Tb-1.0)
7234                   pw4 = 4.76955*(1.0-Ta)
7235                   pwr = cw1*(1.0-Ta) + cw2*LOG10(Tb) + cw3*(1.0-10.0**pw3) + cw4*(10.0**pw4-1.0) + cw5
7236                   es = 10.0**pwr             ! Saturation WVP
7237                   wvp = 0.01*rh(i,k,j)*es    ! Actual WVP
7238                   pmb = p(i,k,j)/100.
7239                   wvpmax = EP_MAX*pmb        ! Prevents unrealistic QV in the stratosphere
7240                   wvp = MIN(wvp,wvpmax)
7241                   q(i,k,j) = eps*wvp/(pmb-wvp)
7242                END DO
7243             END DO
7244          END DO
7245
7246       ELSE
7247          DO j = jts , MIN ( jde-1 , jte )
7248             DO k = kts , kte
7249                DO i = its , MIN (ide-1 , ite )
7250                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7251                   Ta=Tn/T(i,k,j)
7252                   Tb=T(i,k,j)/Tn
7253                   IF (t(i,k,j) >= T0K) THEN         ! Over liquid water
7254                      pw3 = -8.2969*(Tb-1.0)
7255                      pw4 = 4.76955*(1.0-Ta)
7256                      pwr = cw1*(1.0-Ta) + cw2*LOG10(Tb) + cw3*(1.0-10.0**pw3) + cw4*(10.0**pw4-1.0) + cw5
7257                      es = 10.0**pwr
7258                      wvp = 0.01*rh(i,k,j)*es
7259                   ELSE IF (t(i,k,j) <= Tice) THEN   ! Over ice
7260                      pwr = ci1*(Ta-1.0) + ci2*LOG10(Ta) + ci3*(1.0-Tb) + ci4
7261                      es = 10.0**pwr
7262                      wvp = 0.01*rh(i,k,j)*es
7263                   ELSE                              ! Mixed
7264                      pw3 = -8.2969*(Tb-1.0)
7265                      pw4 = 4.76955*(1.0-Ta)
7266                      pwr = cw1*(1.0-Ta) + cw2*LOG10(Tb) + cw3*(1.0-10.0**pw3) + cw4*(10.0**pw4-1.0) + cw5
7267                      esw = 10.0**pwr      ! Over liquid water
7268
7269                      pwr = ci1*(Ta-1.0) + ci2*LOG10(Ta) + ci3*(1.0-Tb) + ci4
7270                      esi = 10.0**pwr      ! Over ice
7271
7272                      es = esi + (esw-esi)*cfe*(T(i,k,j)-Tice)*(T(i,k,j)-Tice)
7273                      wvp = 0.01*rh(i,k,j)*es
7274                   END IF
7275                   pmb = p(i,k,j)/100.
7276                   wvpmax = EP_MAX*pmb     ! Prevents unrealistic QV in the stratosphere
7277                   wvp = MIN(wvp,wvpmax)
7278                   q(i,k,j) = eps*wvp/(pmb-wvp)
7279                END DO
7280             END DO
7281          END DO
7282       END IF
7283
7284       !  For pressures above a defined level, reasonable Qv values should be
7285       !  a certain value or smaller.  If they are larger than this, the input data
7286       !  probably had "missing" RH, and we filled in some values.  This is an
7287       !  attempt to catch those.  Also, set the minimum value for the entire
7288       !  domain that is above the selected pressure level.
7289
7290       DO j = jts , MIN ( jde-1 , jte )
7291          DO k = kts , kte
7292             DO i = its , MIN (ide-1 , ite )
7293                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7294                IF ( p(i,k,j) .LT. qv_max_p_safe ) THEN
7295                   IF ( q(i,k,j) .GT. qv_max_flag ) THEN
7296                      q(i,k,j) = qv_max_value
7297                   END IF
7298                END IF
7299                IF ( p(i,k,j) .LT. qv_min_p_safe ) THEN
7300                   IF ( q(i,k,j) .LT. qv_min_flag ) THEN
7301                      q(i,k,j) = qv_min_value
7302                   END IF
7303                END IF
7304             END DO
7305          END DO
7306       END DO
7307
7308    END SUBROUTINE rh_to_mxrat2
7309
7310 !---------------------------------------------------------------------
7311
7312    SUBROUTINE rh_to_mxrat1(rh, t, p, q , wrt_liquid , &
7313                            qv_max_p_safe , &
7314                            qv_max_flag , qv_max_value , &
7315                            qv_min_p_safe , &
7316                            qv_min_flag , qv_min_value , &
7317                            ids , ide , jds , jde , kds , kde , &
7318                            ims , ime , jms , jme , kms , kme , &
7319                            its , ite , jts , jte , kts , kte )
7320
7321       IMPLICIT NONE
7322
7323       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
7324                                      ims , ime , jms , jme , kms , kme , &
7325                                      its , ite , jts , jte , kts , kte
7326
7327       LOGICAL , INTENT(IN)        :: wrt_liquid
7328
7329       REAL , INTENT(IN)           :: qv_max_p_safe , qv_max_flag , qv_max_value
7330       REAL , INTENT(IN)           :: qv_min_p_safe , qv_min_flag , qv_min_value
7331
7332       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN)     :: p , t
7333       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT)  :: rh
7334       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT)    :: q
7335
7336       !  Local vars
7337
7338       INTEGER                     :: i , j , k
7339
7340       REAL                        :: ew , q1 , t1
7341
7342       REAL,         PARAMETER     :: T_REF       = 0.0
7343       REAL,         PARAMETER     :: MW_AIR      = 28.966
7344       REAL,         PARAMETER     :: MW_VAP      = 18.0152
7345
7346       REAL,         PARAMETER     :: A0       = 6.107799961
7347       REAL,         PARAMETER     :: A1       = 4.436518521e-01
7348       REAL,         PARAMETER     :: A2       = 1.428945805e-02
7349       REAL,         PARAMETER     :: A3       = 2.650648471e-04
7350       REAL,         PARAMETER     :: A4       = 3.031240396e-06
7351       REAL,         PARAMETER     :: A5       = 2.034080948e-08
7352       REAL,         PARAMETER     :: A6       = 6.136820929e-11
7353
7354       REAL,         PARAMETER     :: ES0 = 6.1121
7355
7356       REAL,         PARAMETER     :: C1       = 9.09718
7357       REAL,         PARAMETER     :: C2       = 3.56654
7358       REAL,         PARAMETER     :: C3       = 0.876793
7359       REAL,         PARAMETER     :: EIS      = 6.1071
7360       REAL                        :: RHS
7361       REAL,         PARAMETER     :: TF       = 273.16
7362       REAL                        :: TK
7363
7364       REAL                        :: ES
7365       REAL                        :: QS
7366       REAL,         PARAMETER     :: EPS         = 0.622
7367       REAL,         PARAMETER     :: SVP1        = 0.6112
7368       REAL,         PARAMETER     :: SVP2        = 17.67
7369       REAL,         PARAMETER     :: SVP3        = 29.65
7370       REAL,         PARAMETER     :: SVPT0       = 273.15
7371
7372       CHARACTER (LEN=80) :: mess
7373
7374       !  This subroutine computes mixing ratio (q, kg/kg) from basic variables
7375       !  pressure (p, Pa), temperature (t, K) and relative humidity (rh, 1-100%).
7376       !  The reference temperature (t_ref, C) is used to describe the temperature
7377       !  at which the liquid and ice phase change occurs.
7378
7379       DO j = jts , MIN ( jde-1 , jte )
7380          DO k = kts , kte
7381             DO i = its , MIN (ide-1 , ite )
7382                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7383                rh(i,k,j) = MIN ( MAX ( rh(i,k,j) ,  0. ) , 100. )
7384             END DO
7385          END DO
7386       END DO
7387
7388       IF ( wrt_liquid ) THEN
7389          DO j = jts , MIN ( jde-1 , jte )
7390             DO k = kts , kte
7391                DO i = its , MIN (ide-1 , ite )
7392                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7393
7394 ! es is reduced by RH here to avoid problems in low-pressure cases
7395                   if (t(i,k,j) .ne. 0.) then
7396                      es=.01*rh(i,k,j)*svp1*10.*EXP(svp2*(t(i,k,j)-svpt0)/(t(i,k,j)-svp3))
7397                      IF (es .ge. p(i,k,j)/100.)THEN
7398                        q(i,k,j)=1.E-6
7399                        WRITE(mess,*) 'Warning: vapor pressure exceeds total pressure, setting Qv to 1.E-6'
7400                        CALL wrf_debug(1,mess)
7401                      ELSE
7402                        q(i,k,j)=MAX(eps*es/(p(i,k,j)/100.-es),1.E-6)
7403                      ENDIF
7404                   else
7405                      q(i,k,j)=1.E-6
7406                      WRITE(mess,*) 't(i,j,k) was 0 at ', i,j,k,', setting Qv to 0'
7407                      CALL wrf_debug(0,mess)
7408                   endif
7409                END DO
7410             END DO
7411          END DO
7412
7413       ELSE
7414          DO j = jts , MIN ( jde-1 , jte )
7415             DO k = kts , kte
7416                DO i = its , MIN (ide-1 , ite )
7417                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7418
7419                   t1 = t(i,k,j) - 273.16
7420
7421                   !  Obviously dry.
7422
7423                   IF ( t1 .lt. -200. ) THEN
7424                      q(i,k,j) = 0
7425
7426                   ELSE
7427
7428                      !  First compute the ambient vapor pressure of water
7429
7430                      !  Liquid phase t > 0 C
7431
7432                      IF ( t1 .GE. t_ref ) THEN
7433                         ew = a0 + t1 * (a1 + t1 * (a2 + t1 * (a3 + t1 * (a4 + t1 * (a5 + t1 * a6)))))
7434
7435                      !  Mixed phase -47 C < t < 0 C
7436
7437                      ELSE IF ( ( t1 .LT. t_ref ) .AND. ( t1 .GE. -47. ) ) THEN
7438                         ew = es0 * exp(17.67 * t1 / ( t1 + 243.5))
7439
7440                      !  Ice phase t < -47 C
7441
7442                      ELSE IF ( t1 .LT. -47. ) THEN
7443                         tk = t(i,k,j)
7444                         rhs = -c1 * (tf / tk - 1.) - c2 * alog10(tf / tk) +  &
7445                                c3 * (1. - tk / tf) +      alog10(eis)
7446                         ew = 10. ** rhs
7447
7448                      END IF
7449
7450                      !  Now sat vap pres obtained compute local vapor pressure
7451
7452                      ew = MAX ( ew , 0. ) * rh(i,k,j) * 0.01
7453
7454                      !  Now compute the specific humidity using the partial vapor
7455                      !  pressures of water vapor (ew) and dry air (p-ew).  The
7456                      !  constants assume that the pressure is in hPa, so we divide
7457                      !  the pressures by 100.
7458
7459                      q1 = mw_vap * ew
7460                      q1 = q1 / (q1 + mw_air * (p(i,k,j)/100. - ew))
7461
7462                      q(i,k,j) = q1 / (1. - q1 )
7463
7464                   END IF
7465
7466                END DO
7467             END DO
7468          END DO
7469       END IF
7470
7471       !  For pressures above a defined level, reasonable Qv values should be
7472       !  a certain value or smaller.  If they are larger than this, the input data
7473       !  probably had "missing" RH, and we filled in some values.  This is an
7474       !  attempt to catch those.  Also, set the minimum value for the entire
7475       !  domain that is above the selected pressure level.
7476
7477       DO j = jts , MIN ( jde-1 , jte )
7478          DO k = kts , kte
7479             DO i = its , MIN (ide-1 , ite )
7480                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7481                IF ( p(i,k,j) .LT. qv_max_p_safe ) THEN
7482                   IF ( q(i,k,j) .GT. qv_max_flag ) THEN
7483                      q(i,k,j) = qv_max_value
7484                   END IF
7485                END IF
7486                IF ( p(i,k,j) .LT. qv_min_p_safe ) THEN
7487                   IF ( q(i,k,j) .LT. qv_min_flag ) THEN
7488                      q(i,k,j) = qv_min_value
7489                   END IF
7490                END IF
7491             END DO
7492          END DO
7493       END DO
7494
7495    END SUBROUTINE rh_to_mxrat1
7496
7497 !---------------------------------------------------------------------
7498
7499 #if 0
7500 program foo
7501
7502 !  Make this local variable have the same value as in
7503 !  frame/module_driver_constants.F: MAX_ETA
7504 integer , parameter :: max_eta = 10001
7505
7506 INTEGER :: ids , ide , jds , jde , kds , kde , &
7507            ims , ime , jms , jme , kms , kme , &
7508            its , ite , jts , jte , kts , kte
7509
7510 real :: max_dz = 1000
7511 real :: p_top = 100
7512 real :: g = 9.81
7513 real :: p00 = 100000
7514 real :: cvpm = -0.714285731
7515 real :: a = 50
7516 real :: r_d = 287
7517 real :: cp = 1004.5
7518 real :: t00 = 290
7519 real :: p1000mb = 100000
7520 real :: t0 = 300
7521 real :: tiso = 216.649994
7522 real :: p_strat = 5500
7523 real :: a_strat = -12
7524
7525 real , dimension(max_eta) :: znw , eta_levels
7526
7527 eta_levels = -1
7528
7529 kds=1
7530 kms=1
7531 kts=1
7532 kde=70
7533 kme=70
7534 kte=70
7535
7536
7537 call compute_eta ( znw , auto_levels_opt, &
7538                    eta_levels , max_eta , max_dz , dzbot , dzstretch_s , dzstretch_u , &
7539                    p_top , g , p00 , cvpm , a , r_d , cp , &
7540                    t00 , p1000mb , t0 , tiso , p_strat , a_strat , &
7541                    ids , ide , jds , jde , kds , kde , &
7542                    ims , ime , jms , jme , kms , kme , &
7543                    its , ite , jts , jte , kts , kte )
7544
7545 end program foo
7546 #endif
7547
7548    SUBROUTINE compute_eta ( znw , auto_levels_opt , &
7549                            eta_levels , max_eta , max_dz , dzbot , dzstretch_s , dzstretch_u , &
7550                            p_top , g , p00 , cvpm , a , r_d , cp , &
7551                            t00 , p1000mb , t0 , tiso , p_strat , a_strat , &
7552                            ids , ide , jds , jde , kds , kde , &
7553                            ims , ime , jms , jme , kms , kme , &
7554                            its , ite , jts , jte , kts , kte )
7555
7556       !  Compute eta levels, either using given values from the namelist (hardly
7557       !  a computation, yep, I know), or assuming a constant dz above the PBL,
7558       !  knowing p_top and the number of eta levels.
7559
7560       IMPLICIT NONE
7561
7562       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
7563                                      ims , ime , jms , jme , kms , kme , &
7564                                      its , ite , jts , jte , kts , kte
7565       REAL , INTENT(IN)           :: max_dz, dzbot, dzstretch_s, dzstretch_u
7566       REAL , INTENT(IN)           :: p_top , g , p00 , cvpm , a , r_d , cp , t00 , p1000mb , t0 , tiso
7567       REAL , INTENT(IN)           :: p_strat , a_strat
7568       INTEGER , INTENT(IN)        :: max_eta, auto_levels_opt
7569       REAL , DIMENSION (max_eta)  :: eta_levels
7570
7571       REAL , DIMENSION (kts:kte) , INTENT(OUT) :: znw
7572
7573       !  Local vars
7574
7575       INTEGER :: k , kk
7576       REAL(KIND=8) :: mub , t_init , p_surf , pb, ztop, ztop_pbl , dz , temp
7577       REAL(KIND=8) , DIMENSION(kts:kte) :: dnw
7578
7579       INTEGER , PARAMETER :: prac_levels = 59
7580       INTEGER :: loop , loop1
7581       REAL(KIND=8) , DIMENSION(prac_levels) :: znw_prac , znu_prac , dnw_prac
7582       REAL(KIND=8) , DIMENSION(MAX(prac_levels,kde)) :: alb , phb
7583       REAL(KIND=8) :: alb_max, t_init_max, pb_max, phb_max
7584       REAL(KIND=8) :: p00_r8, t00_r8, a_r8, tiso_r8
7585
7586       CHARACTER(LEN=256) :: message
7587
7588       !  Gee, do the eta levels come in from the namelist?
7589
7590       IF ( ABS(eta_levels(1)+1.) .GT. 0.0000001 ) THEN
7591
7592          !  Check to see if the array is oriented OK, we can easily fix an upside down oops.
7593
7594          IF      ( ( ABS(eta_levels(1  )-1.) .LT. 0.0000001 ) .AND. &
7595                    ( ABS(eta_levels(kde)-0.) .LT. 0.0000001 ) ) THEN
7596             DO k = kds+1 , kde-1
7597         znw(k) = eta_levels(k)
7598             END DO
7599             znw(  1) = 1.
7600             znw(kde) = 0.
7601          ELSE IF ( ( ABS(eta_levels(kde)-1.) .LT. 0.0000001 ) .AND. &
7602                    ( ABS(eta_levels(1  )-0.) .LT. 0.0000001 ) ) THEN
7603             DO k = kds+1 , kde-1
7604         znw(k) = eta_levels(kde+1-k)
7605             END DO
7606             znw(  1) = 1.
7607             znw(kde) = 0.
7608          ELSE
7609             CALL wrf_error_fatal ( 'First eta level should be 1.0 and the last 0.0 in namelist' )
7610          END IF
7611
7612          !  Check to see if the input full-level eta array is monotonic.
7613
7614          DO k = kds , kde-1
7615             IF ( znw(k) .LE. znw(k+1) ) THEN
7616                PRINT *,'eta on full levels is not monotonic'
7617                PRINT *,'eta (',k,') = ',znw(k)
7618                PRINT *,'eta (',k+1,') = ',znw(k+1)
7619                CALL wrf_error_fatal ( 'Fix non-monotonic "eta_levels" in the namelist.input file' )
7620             END IF
7621          END DO
7622
7623       !  Compute eta levels assuming a constant delta z above the PBL.
7624
7625       ELSE
7626        IF( auto_levels_opt == 1 ) THEN
7627          print *,'using old automatic levels program'
7628          !  Compute top of the atmosphere with some silly levels.  We just want to
7629          !  integrate to get a reasonable value for ztop.  We use the planned PBL-esque
7630          !  levels, and then just coarse resolution above that.  We know p_top, and we
7631          !  have the base state vars.
7632
7633          p_surf = p00
7634
7635          znw_prac = (/ 1.0000_8 , 0.9930_8 , 0.9830_8 , 0.9700_8 , 0.9540_8 , 0.9340_8 , 0.9090_8 , 0.8800_8 , &
7636                        0.8500_8 , 0.8000_8 , 0.7500_8 , 0.7000_8 , 0.6500_8 , 0.6000_8 , 0.5500_8 , 0.5000_8 , &
7637                        0.4500_8 , 0.4000_8 , 0.3500_8 , 0.3000_8 , 0.2500_8 , 0.2000_8 , 0.1500_8 , 0.1000_8 , &
7638                        0.0800_8 , 0.0600_8 , 0.0400_8 , 0.0200_8 , &
7639                        0.0150_8 , 0.0100_8 , 0.0090_8 , 0.0080_8 , 0.0070_8 , 0.0060_8 , 0.0050_8 , 0.0040_8 , &
7640                        0.0035_8 , 0.0030_8 , &
7641                        0.0028_8 , 0.0026_8 , 0.0024_8 , 0.0022_8 , 0.0020_8 , &
7642                        0.0018_8 , 0.0016_8 , 0.0014_8 , 0.0012_8 , 0.0010_8 , &
7643                        0.0009_8 , 0.0008_8 , 0.0007_8 , 0.0006_8 , 0.0005_8 , 0.0004_8 , 0.0003_8 , &
7644                        0.0002_8 , 0.0001_8 , 0.00005_8, 0.0000_8 /)
7645
7646          DO k = 1 , prac_levels - 1
7647             znu_prac(k) = ( znw_prac(k) + znw_prac(k+1) ) * 0.5_8
7648             dnw_prac(k) = znw_prac(k+1) - znw_prac(k)
7649          END DO
7650
7651          tiso_r8    = tiso
7652          t00_r8     = t00
7653          a_r8       = a
7654          p00_r8     = p00
7655          DO k = 1, prac_levels-1
7656             pb = znu_prac(k)*(p_surf - p_top) + p_top
7657             temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7658             IF ( pb .LT. p_strat ) THEN
7659                 temp = tiso + A_strat*LOG(pb/p_strat)
7660             END IF
7661             t_init = temp*(p00/pb)**(r_d/cp) - t0
7662             alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7663          END DO
7664
7665          !  Base state mu is defined as base state surface pressure minus p_top
7666
7667          mub = p_surf - p_top
7668
7669          !  Integrate base geopotential, starting at terrain elevation.
7670
7671          phb(1) = 0._8
7672          DO k  = 2,prac_levels
7673                phb(k) = phb(k-1) - dnw_prac(k-1)*mub*alb(k-1)
7674          END DO
7675
7676          !  So, now we know the model top in meters.  Get the average depth above the PBL
7677          !  of each of the remaining levels.  We are going for a constant delta z thickness.
7678
7679          ztop     = phb(prac_levels) / g
7680          ztop_pbl = phb(8          ) / g
7681          dz = ( ztop - ztop_pbl ) / REAL ( kde - 8 )
7682
7683          IF ( dz .GE. max_dz ) THEN
7684             WRITE (message,FMT='("With a requested ",F7.1," Pa model top, the model lid will be about ",F7.1," m.")') p_top, ztop
7685             CALL wrf_message ( message )
7686             WRITE (message,FMT='("With ",I3," levels above the PBL, the level thickness will be about ",F6.1," m.")') kde-8, dz
7687             CALL wrf_message ( message )
7688             WRITE (message,FMT='("Thicknesses greater than ",F7.1," m are not recommended.")') max_dz
7689             CALL wrf_message ( message )
7690             CALL wrf_error_fatal ( 'Add more levels to namelist.input for e_vert' )
7691          END IF
7692
7693          !  Standard levels near the surface so no one gets in trouble.
7694
7695          DO k = 1 , 8
7696             eta_levels(k) = znw_prac(k)
7697          END DO
7698
7699          !  Using d phb(k)/ d eta(k) = -mub * alb(k), eqn 2.9
7700          !  Skamarock et al, NCAR TN 468.  Use full levels, so
7701          !  use twice the thickness.
7702
7703          DO k = 8, kte-1-2
7704
7705             find_prac : DO kk = 1 , prac_levels
7706                IF (znw_prac(kk) .LT. eta_levels(k) ) THEN
7707                   EXIT find_prac
7708                END IF
7709             end do find_prac
7710
7711             pb = 0.5*(eta_levels(k)+znw_prac(kk)) * (p_surf - p_top) + p_top
7712
7713             temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7714             IF ( pb .LT. p_strat ) THEN
7715                temp = tiso + A_strat * LOG ( pb/p_strat )
7716             END IF
7717 !           temp =             t00 + A*LOG(pb/p00)
7718             t_init = temp*(p00/pb)**(r_d/cp) - t0
7719             alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7720             eta_levels(k+1) = eta_levels(k) - dz*g / ( mub*alb(k) )
7721             pb = 0.5*(eta_levels(k)+eta_levels(k+1)) * (p_surf - p_top) + p_top
7722
7723             temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7724             IF ( pb .LT. p_strat ) THEN
7725                temp = tiso + A_strat * LOG ( pb/p_strat )
7726             END IF
7727 !           temp =             t00 + A*LOG(pb/p00)
7728             t_init = temp*(p00/pb)**(r_d/cp) - t0
7729             alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7730             eta_levels(k+1) = eta_levels(k) - dz*g / ( mub*alb(k) )
7731             pb = 0.5*(eta_levels(k)+eta_levels(k+1)) * (p_surf - p_top) + p_top
7732
7733             phb(k+1) = phb(k) - (eta_levels(k+1)-eta_levels(k)) * mub*alb(k)
7734          END DO
7735
7736          alb_max = alb(kte-1-2)
7737          t_init_max = t_init
7738          pb_max = pb
7739          phb_max = phb(kte-1)
7740
7741          DO k = 1 , kte-1-2
7742             znw(k) = eta_levels(k)
7743          END DO
7744          znw(kte-2) = 0.000
7745
7746          !  There is some iteration.  We want the top level, ztop, to be
7747          !  consistent with the delta z, and we want the half level values
7748          !  to be consistent with the eta levels.  The inner loop to 10 gets
7749          !  the eta levels very accurately, but has a residual at the top, due
7750          !  to dz changing.  We reset dz five times, and then things seem OK.
7751
7752          DO loop1 = 1 , 5
7753             DO loop = 1 , 10
7754                DO k = 8, kte-1-2-1
7755                   pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top
7756                   temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7757                   IF ( pb .LT. p_strat ) THEN
7758                      temp = tiso + A_strat * LOG ( pb/p_strat )
7759                   END IF
7760                   t_init = temp*(p00/pb)**(r_d/cp) - t0
7761                   alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7762                   znw(k+1) = znw(k) - dz*g / ( mub*alb(k) )
7763                END DO
7764                pb = pb_max
7765                t_init = t_init_max
7766                alb(kte-1-2) = alb_max
7767                znw(kte-2) = znw(kte-1-2) - dz*g / ( mub*alb(kte-1-2) )
7768                IF ( ( loop1 .EQ. 5 ) .AND. ( loop .EQ. 10 ) ) THEN
7769                   print *,'Converged znw(kte) should be about 0.0 = ',znw(kte-2)
7770                END IF
7771                znw(kte-2) = 0.000
7772             END DO
7773
7774             !  Here is where we check the eta levels values we just computed.
7775
7776             DO k = 1, kde-1-2
7777                pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top
7778                temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7779                IF ( pb .LT. p_strat ) THEN
7780                   temp = tiso + A_strat * LOG ( pb/p_strat )
7781                END IF
7782                t_init = temp*(p00/pb)**(r_d/cp) - t0
7783                alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7784             END DO
7785
7786             phb(1) = 0.
7787             DO k  = 2,kde-2
7788                phb(k) = phb(k-1) - (znw(k)-znw(k-1)) * mub*alb(k-1)
7789             END DO
7790
7791             !  Reset the model top and the dz, and iterate.
7792
7793             ztop = phb(kde-2)/g
7794             ztop_pbl = phb(8)/g
7795             dz = ( ztop - ztop_pbl ) / REAL ( (kde-2) - 8 )
7796          END DO
7797
7798          IF ( dz .GT. max_dz ) THEN
7799 print *,'z (m)            = ',phb(1)/g
7800 do k = 2 ,kte-2
7801 print *,'z (m) and dz (m) = ',phb(k)/g,(phb(k)-phb(k-1))/g
7802 end do
7803 print *,'dz (m) above fixed eta levels = ',dz
7804 print *,'namelist max_dz (m) = ',max_dz
7805 print *,'namelist p_top (Pa) = ',p_top
7806             CALL wrf_debug ( 0, 'You need one of three things:' )
7807             CALL wrf_debug ( 0, '1) More eta levels to reduce the dz: e_vert' )
7808             CALL wrf_debug ( 0, '2) A lower p_top so your total height is reduced: p_top_requested')
7809             CALL wrf_debug ( 0, '3) Increase the maximum allowable eta thickness: max_dz')
7810             CALL wrf_debug ( 0, 'All are namelist options')
7811             CALL wrf_error_fatal ( 'dz above fixed eta levels is too large')
7812          END IF
7813
7814          !  Add those 2 levels back into the middle, just above the 8 levels
7815          !  that semi define a boundary layer.  After we open up the levels,
7816          !  then we just linearly interpolate in znw.  So now levels 1-8 are
7817          !  specified as the fixed boundary layer levels given in this routine.
7818          !  The top levels, 12 through kte are those computed.  The middle
7819          !  levels 9, 10, and 11 are equi-spaced in znw, and are each 1/2 the
7820          !  the znw thickness of levels 11 through 12.
7821
7822          DO k = kte-2 , 9 , -1
7823             znw(k+2) = znw(k)
7824          END DO
7825
7826          znw( 9) = 0.75 * znw( 8) + 0.25 * znw(12)
7827          znw(10) = 0.50 * znw( 8) + 0.50 * znw(12)
7828          znw(11) = 0.25 * znw( 8) + 0.75 * znw(12)
7829
7830          DO k = 8, kte-1
7831             pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top
7832             temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7833             IF ( pb .LT. p_strat ) THEN
7834                temp = tiso + A_strat * LOG ( pb/p_strat )
7835             END IF
7836             t_init = temp*(p00/pb)**(r_d/cp) - t0
7837             alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7838             phb(k) = phb(k-1) - (znw(k)-znw(k-1)) * mub*alb(k-1)
7839          END DO
7840          phb(kte) = phb(kte-1) - (znw(kte)-znw(kte-1)) * mub*alb(kte-1)
7841
7842        ELSE IF (auto_levels_opt == 2) THEN
7843          print *,'using new automatic levels program'
7844          CALL levels(kte-1, p_top, znw, max_dz, dzbot, dzstretch_s, dzstretch_u, r_d, g )
7845          p_surf = p00
7846          tiso_r8    = tiso
7847          t00_r8     = t00
7848          a_r8       = a
7849          p00_r8     = p00
7850          mub = p_surf - p_top
7851          phb(1) = 0.
7852          DO k = 1, kte-1
7853             pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top
7854             temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7855             IF ( pb .LT. p_strat ) THEN
7856                temp = tiso + A_strat * LOG ( pb/p_strat )
7857             END IF
7858             t_init = temp*(p00/pb)**(r_d/cp) - t0
7859             alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7860             phb(k+1) = phb(k) - (znw(k+1)-znw(k)) * mub*alb(k)
7861          END DO
7862        ELSE
7863          print *,'auto_levels_opt=',auto_levels_opt
7864          CALL wrf_error_fatal ( 'auto_levels_opt needs to be 1 or 2')
7865        ENDIF
7866 k=1
7867 WRITE (*,FMT='("Full level index = ",I4,"     Height = ",F7.1," m")') k,phb(1)/g
7868 do k = 2 ,kte
7869 WRITE (*,FMT='("Full level index = ",I4,"     Height = ",F7.1," m      Thickness = ",F6.1," m")') k,phb(k)/g,(phb(k)-phb(k-1))/g
7870 end do
7871 WRITE (*,FMT='("p_top = ",F7.0," Pa, dzbot = ",F6.1," m, dzstretch_s/u = ",2F6.2)') p_top,dzbot,dzstretch_s,dzstretch_u
7872
7873       END IF
7874
7875    END SUBROUTINE compute_eta
7876
7877 !---------------------------------------------------------------------
7878     SUBROUTINE levels ( nlev, ptop, eta, dzmax, dzbot, dzstretch_s, dzstretch_u, r_d, g )
7879     implicit none
7880     integer, intent(in) :: nlev
7881     real, intent(in) :: ptop, dzmax, dzbot, dzstretch_s, dzstretch_u, r_d, g
7882     real, dimension(0:nlev), intent(out) :: eta
7883
7884     real, dimension(nlev) :: zup, pup
7885     real :: tt, a
7886     real :: ztop, dz, dztest, zscale
7887     integer :: isave, i
7888
7889     tt=290. ! isothermal temperature used for z/log p relation - tt=290 fits dzbot
7890     ztop=r_d*tt/g*alog(1.e5/ptop)
7891     zscale=r_d*tt/g
7892     dz=dzbot
7893     zup(1)=dz
7894     pup(1)=1.e5*exp(-g*zup(1)/r_d/tt)
7895     eta(0)=1.0
7896     eta(1)=(pup(1)-ptop)/(1.e5-ptop)
7897     print *,1,dz,zup(1),eta(1)
7898     isave=1
7899     do i=1,nlev-1
7900         a=dzstretch_u+(dzstretch_s-dzstretch_u)*max((dzmax*0.5-dz)/(dzmax*0.5), 0.)
7901         dz=a*dz
7902         dztest=(ztop-zup(isave))/(nlev-isave)
7903         if(dztest.lt.dz)exit
7904         isave=i+1
7905         zup(i+1)=zup(i)+dz
7906         pup(i+1)=1.e5*exp(-g*zup(i+1)/r_d/tt)
7907         eta(i+1)=(pup(i+1)-ptop)/(1.e5-ptop)
7908         print *,i+1,dz,zup(i+1),eta(i+1),a
7909          IF ( i .EQ. nlev-1 ) THEN
7910             CALL wrf_debug ( 0, 'You need one of four things:' )
7911             CALL wrf_debug ( 0, '1) More eta levels: e_vert' )
7912             CALL wrf_debug ( 0, '2) A lower p_top: p_top_requested')
7913             CALL wrf_debug ( 0, '3) Increase the lowest eta thickness: dzbot')
7914             CALL wrf_debug ( 0, '4) Increase the stretching factor: dzstretch_s or dzstretch_u')
7915             CALL wrf_debug ( 0, 'All are namelist options')
7916             CALL wrf_error_fatal ( 'not enough eta levels to reach p_top')
7917          END IF
7918     enddo
7919     print *,ztop,zup(isave),nlev,isave
7920     dz=(ztop-zup(isave))/(nlev-isave)
7921          IF ( dz .GT. 1.5*dzmax ) THEN       ! isothermal temp 1.5 times stratosphere temp
7922             CALL wrf_debug ( 0, 'Warning: Upper levels may be too thick' )
7923             CALL wrf_debug ( 0, 'You need one of five things:' )
7924             CALL wrf_debug ( 0, '1) More eta levels: e_vert' )
7925             CALL wrf_debug ( 0, '2) A lower p_top: p_top_requested')
7926             CALL wrf_debug ( 0, '3) Increase the lowest eta thickness: dzbot')
7927             CALL wrf_debug ( 0, '4) Increase the stretching factor: dzstretch_s or dzstretch_u')
7928             CALL wrf_debug ( 0, '5) Increase the maximum allowed thickness: max_dz')
7929             CALL wrf_debug ( 0, 'All are namelist options')
7930             CALL wrf_error_fatal ( 'Upper levels may be too thick')
7931          END IF
7932     do i=isave,nlev-1
7933         zup(i+1)=zup(i)+dz
7934         pup(i+1)=1.e5*exp(-g*zup(i+1)/r_d/tt)
7935         eta(i+1)=(pup(i+1)-ptop)/(1.e5-ptop)
7936         print *,i+1,dz,zup(i+1),eta(i+1)
7937     enddo
7938     eta(nlev) = 0.
7939     print 1000, eta
7940     1000 format(10f10.4)
7941     !1000 format(10g10.3)
7942     return
7943     END SUBROUTINE levels
7944
7945 !---------------------------------------------------------------------
7946
7947    SUBROUTINE monthly_min_max ( field_in , field_min , field_max , &
7948                       ids , ide , jds , jde , kds , kde , &
7949                       ims , ime , jms , jme , kms , kme , &
7950                       its , ite , jts , jte , kts , kte )
7951
7952    !  Plow through each month, find the max, min values for each i,j.
7953
7954       IMPLICIT NONE
7955
7956       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
7957                                      ims , ime , jms , jme , kms , kme , &
7958                                      its , ite , jts , jte , kts , kte
7959
7960       REAL , DIMENSION(ims:ime,12,jms:jme) , INTENT(IN)  :: field_in
7961       REAL , DIMENSION(ims:ime,   jms:jme) , INTENT(OUT) :: field_min , field_max
7962
7963       !  Local vars
7964
7965       INTEGER :: i , j , l
7966       REAL :: minner , maxxer
7967
7968       DO j = jts , MIN(jde-1,jte)
7969          DO i = its , MIN(ide-1,ite)
7970             minner = field_in(i,1,j)
7971             maxxer = field_in(i,1,j)
7972             DO l = 2 , 12
7973                IF ( field_in(i,l,j) .LT. minner ) THEN
7974                   minner = field_in(i,l,j)
7975                END IF
7976                IF ( field_in(i,l,j) .GT. maxxer ) THEN
7977                   maxxer = field_in(i,l,j)
7978                END IF
7979             END DO
7980             field_min(i,j) = minner
7981             field_max(i,j) = maxxer
7982          END DO
7983       END DO
7984
7985    END SUBROUTINE monthly_min_max
7986
7987 !---------------------------------------------------------------------
7988
7989    SUBROUTINE monthly_avg ( field_in , field_avg , &
7990                       ids , ide , jds , jde , kds , kde , &
7991                       ims , ime , jms , jme , kms , kme , &
7992                       its , ite , jts , jte , kts , kte )
7993       IMPLICIT NONE
7994       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
7995                                      ims , ime , jms , jme , kms , kme , &
7996                                      its , ite , jts , jte , kts , kte
7997       REAL , DIMENSION(ims:ime,12,jms:jme) , INTENT(IN)  :: field_in
7998       REAL , DIMENSION(ims:ime,   jms:jme) , INTENT(OUT) :: field_avg
7999       !  Local vars
8000       INTEGER :: i , j
8001       DO j = jts , MIN(jde-1,jte)
8002         DO i = its , MIN(ide-1,ite)
8003           field_avg(i, j) = SUM(field_in(i, :, j)) / 12
8004         END DO
8005       END DO
8006    END SUBROUTINE monthly_avg
8007
8008 !---------------------------------------------------------------------
8009
8010    SUBROUTINE monthly_interp_to_date ( field_in , date_str , field_out , &
8011                       ids , ide , jds , jde , kds , kde , &
8012                       ims , ime , jms , jme , kms , kme , &
8013                       its , ite , jts , jte , kts , kte )
8014
8015    !  Linrarly in time interpolate data to a current valid time.  The data is
8016    !  assumed to come in "monthly", valid at the 15th of every month.
8017
8018       IMPLICIT NONE
8019
8020       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
8021                                      ims , ime , jms , jme , kms , kme , &
8022                                      its , ite , jts , jte , kts , kte
8023
8024       CHARACTER (LEN=24) , INTENT(IN) :: date_str
8025       REAL , DIMENSION(ims:ime,12,jms:jme) , INTENT(IN)  :: field_in
8026       REAL , DIMENSION(ims:ime,   jms:jme) , INTENT(OUT) :: field_out
8027
8028       !  Local vars
8029
8030       INTEGER :: i , j , l
8031       INTEGER , DIMENSION(0:13) :: middle
8032       INTEGER :: target_julyr , target_julday , target_date
8033       INTEGER :: julyr , julday , int_month , month1 , month2
8034       REAL :: gmt
8035       CHARACTER (LEN=4) :: yr
8036       CHARACTER (LEN=2) :: mon , day15
8037
8038
8039       WRITE(day15,FMT='(I2.2)') 15
8040       DO l = 1 , 12
8041          WRITE(mon,FMT='(I2.2)') l
8042          CALL get_julgmt ( date_str(1:4)//'-'//mon//'-'//day15//'_'//'00:00:00.0000' , julyr , julday , gmt )
8043          middle(l) = julyr*1000 + julday
8044       END DO
8045
8046       l = 0
8047       middle(l) = middle( 1) - 31
8048
8049       l = 13
8050       middle(l) = middle(12) + 31
8051
8052       CALL get_julgmt ( date_str , target_julyr , target_julday , gmt )
8053       target_date = target_julyr * 1000 + target_julday
8054       find_month : DO l = 0 , 12
8055          IF ( ( middle(l) .LT. target_date ) .AND. ( middle(l+1) .GE. target_date ) ) THEN
8056             DO j = jts , MIN ( jde-1 , jte )
8057                DO i = its , MIN (ide-1 , ite )
8058                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8059                   int_month = l
8060                   IF ( ( int_month .EQ. 0 ) .OR. ( int_month .EQ. 12 ) ) THEN
8061                      month1 = 12
8062                      month2 =  1
8063                   ELSE
8064                      month1 = int_month
8065                      month2 = month1 + 1
8066                   END IF
8067                   field_out(i,j) =  ( field_in(i,month2,j) * ( target_date - middle(l)   ) + &
8068                                       field_in(i,month1,j) * ( middle(l+1) - target_date ) ) / &
8069                                     ( middle(l+1) - middle(l) )
8070                END DO
8071             END DO
8072             EXIT find_month
8073          END IF
8074       END DO find_month
8075
8076    END SUBROUTINE monthly_interp_to_date
8077
8078 !---------------------------------------------------------------------
8079
8080    SUBROUTINE eightday_selector ( field_in , date_str , field_out , &
8081                       ids , ide , jds , jde , kds , kde , &
8082                       ims , ime , jms , jme , kms , kme , &
8083                       its , ite , jts , jte , kts , kte )
8084
8085    !  Given current date, select time-matching monthly entry from grid.
8086    !  No interpolation.
8087
8088       IMPLICIT NONE
8089
8090       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
8091                                      ims , ime , jms , jme , kms , kme , &
8092                                      its , ite , jts , jte , kts , kte
8093
8094       CHARACTER (LEN=24) , INTENT(IN) :: date_str
8095       REAL , DIMENSION(ims:ime,46,jms:jme) , INTENT(IN)  :: field_in  !46
8096       REAL , DIMENSION(ims:ime,   jms:jme) , INTENT(OUT) :: field_out
8097
8098       !  Local vars
8099
8100       INTEGER :: i , j
8101       INTEGER :: julyr, julday, eightday
8102       REAL :: gmt
8103
8104       CALL get_julgmt ( date_str , julyr , julday , gmt )
8105       eightday = ((julday-1) / 8) + 1
8106 !      print *, 'date_str: ', date_str
8107 !      print *, 'julyr, julday: ', julyr, julday
8108 !      print *, 'eightday: ', eightday
8109
8110       DO j = jts , MIN ( jde-1 , jte )
8111          DO i = its , MIN (ide-1 , ite )
8112             field_out(i,j) =  field_in(i,eightday,j)
8113          END DO
8114       END DO
8115
8116    END SUBROUTINE eightday_selector
8117
8118 !---------------------------------------------------------------------
8119
8120    SUBROUTINE sfcprs (t, q, height, pslv, ter, avgsfct, p, &
8121                       psfc, ez_method, &
8122                       ids , ide , jds , jde , kds , kde , &
8123                       ims , ime , jms , jme , kms , kme , &
8124                       its , ite , jts , jte , kts , kte )
8125
8126
8127       !  Computes the surface pressure using the input height,
8128       !  temperature and q (already computed from relative
8129       !  humidity) on p surfaces.  Sea level pressure is used
8130       !  to extrapolate a first guess.
8131
8132       IMPLICIT NONE
8133
8134       REAL, PARAMETER    :: gamma     = 6.5E-3
8135       REAL, PARAMETER    :: pconst    = 10000.0
8136       REAL, PARAMETER    :: Rd        = r_d
8137       REAL, PARAMETER    :: TC        = svpt0 + 17.5
8138
8139       REAL, PARAMETER    :: gammarg   = gamma * Rd / g
8140       REAL, PARAMETER    :: rov2      = Rd / 2.
8141
8142       INTEGER , INTENT(IN) ::  ids , ide , jds , jde , kds , kde , &
8143                                ims , ime , jms , jme , kms , kme , &
8144                                its , ite , jts , jte , kts , kte
8145       LOGICAL , INTENT ( IN ) :: ez_method
8146
8147       REAL , DIMENSION (ims:ime,kms:kme,jms:jme) , INTENT(IN ):: t, q, height, p
8148       REAL , DIMENSION (ims:ime,        jms:jme) , INTENT(IN ):: pslv ,  ter, avgsfct
8149       REAL , DIMENSION (ims:ime,        jms:jme) , INTENT(OUT):: psfc
8150
8151       INTEGER                     :: i
8152       INTEGER                     :: j
8153       INTEGER                     :: k
8154       INTEGER , DIMENSION (its:ite,jts:jte) :: k500 , k700 , k850
8155
8156       LOGICAL                     :: l1
8157       LOGICAL                     :: l2
8158       LOGICAL                     :: l3
8159       LOGICAL                     :: OK
8160
8161       REAL                        :: gamma78     ( its:ite,jts:jte )
8162       REAL                        :: gamma57     ( its:ite,jts:jte )
8163       REAL                        :: ht          ( its:ite,jts:jte )
8164       REAL                        :: p1          ( its:ite,jts:jte )
8165       REAL                        :: t1          ( its:ite,jts:jte )
8166       REAL                        :: t500        ( its:ite,jts:jte )
8167       REAL                        :: t700        ( its:ite,jts:jte )
8168       REAL                        :: t850        ( its:ite,jts:jte )
8169       REAL                        :: tfixed      ( its:ite,jts:jte )
8170       REAL                        :: tsfc        ( its:ite,jts:jte )
8171       REAL                        :: tslv        ( its:ite,jts:jte )
8172
8173       !  We either compute the surface pressure from a time averaged surface temperature
8174       !  (what we will call the "easy way"), or we try to remove the diurnal impact on the
8175       !  surface temperature (what we will call the "other way").  Both are essentially
8176       !  corrections to a sea level pressure with a high-resolution topography field.
8177
8178       IF ( ez_method ) THEN
8179
8180          DO j = jts , MIN(jde-1,jte)
8181             DO i = its , MIN(ide-1,ite)
8182                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8183                psfc(i,j) = pslv(i,j) * ( 1.0 + gamma * ter(i,j) / avgsfct(i,j) ) ** ( - g / ( Rd * gamma ) )
8184             END DO
8185          END DO
8186
8187       ELSE
8188
8189          !  Find the locations of the 850, 700 and 500 mb levels.
8190
8191          k850 = 0                              ! find k at: P=850
8192          k700 = 0                              !            P=700
8193          k500 = 0                              !            P=500
8194
8195          i = its
8196          j = jts
8197          DO k = kts+1 , kte
8198             IF      (NINT(p(i,k,j)) .EQ. 85000) THEN
8199                k850(i,j) = k
8200             ELSE IF (NINT(p(i,k,j)) .EQ. 70000) THEN
8201                k700(i,j) = k
8202             ELSE IF (NINT(p(i,k,j)) .EQ. 50000) THEN
8203                k500(i,j) = k
8204             END IF
8205          END DO
8206
8207          IF ( ( k850(i,j) .EQ. 0 ) .OR. ( k700(i,j) .EQ. 0 ) .OR. ( k500(i,j) .EQ. 0 ) ) THEN
8208
8209             DO j = jts , MIN(jde-1,jte)
8210                DO i = its , MIN(ide-1,ite)
8211                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8212                   psfc(i,j) = pslv(i,j) * ( 1.0 + gamma * ter(i,j) / t(i,1,j) ) ** ( - g / ( Rd * gamma ) )
8213                END DO
8214             END DO
8215
8216             RETURN
8217 #if 0
8218
8219             !  Possibly it is just that we have a generalized vertical coord, so we do not
8220             !  have the values exactly.  Do a simple assignment to a close vertical level.
8221
8222             DO j = jts , MIN(jde-1,jte)
8223                DO i = its , MIN(ide-1,ite)
8224                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8225                   DO k = kts+1 , kte-1
8226                      IF ( ( p(i,k,j) - 85000. )  * ( p(i,k+1,j) - 85000. ) .LE. 0.0 ) THEN
8227                         k850(i,j) = k
8228                      END IF
8229                      IF ( ( p(i,k,j) - 70000. )  * ( p(i,k+1,j) - 70000. ) .LE. 0.0 ) THEN
8230                         k700(i,j) = k
8231                      END IF
8232                      IF ( ( p(i,k,j) - 50000. )  * ( p(i,k+1,j) - 50000. ) .LE. 0.0 ) THEN
8233                         k500(i,j) = k
8234                      END IF
8235                   END DO
8236                END DO
8237             END DO
8238
8239             !  If we *still* do not have the k levels, punt.  I mean, we did try.
8240
8241             OK = .TRUE.
8242             DO j = jts , MIN(jde-1,jte)
8243                DO i = its , MIN(ide-1,ite)
8244                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8245                   IF ( ( k850(i,j) .EQ. 0 ) .OR. ( k700(i,j) .EQ. 0 ) .OR. ( k500(i,j) .EQ. 0 ) ) THEN
8246                      OK = .FALSE.
8247                      PRINT '(A)','(i,j) = ',i,j,'  Error in finding p level for 850, 700 or 500 hPa.'
8248                      DO K = kts+1 , kte
8249                         PRINT '(A,I3,A,F10.2,A)','K = ',k,'  PRESSURE = ',p(i,k,j),' Pa'
8250                      END DO
8251                      PRINT '(A)','Expected 850, 700, and 500 mb values, at least.'
8252                   END IF
8253                END DO
8254             END DO
8255             IF ( .NOT. OK ) THEN
8256                CALL wrf_error_fatal ( 'wrong pressure levels' )
8257             END IF
8258 #endif
8259
8260          !  We are here if the data is isobaric and we found the levels for 850, 700,
8261          !  and 500 mb right off the bat.
8262
8263          ELSE
8264             DO j = jts , MIN(jde-1,jte)
8265                DO i = its , MIN(ide-1,ite)
8266                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8267                   k850(i,j) = k850(its,jts)
8268                   k700(i,j) = k700(its,jts)
8269                   k500(i,j) = k500(its,jts)
8270                END DO
8271             END DO
8272          END IF
8273
8274          !  The 850 hPa level of geopotential height is called something special.
8275
8276          DO j = jts , MIN(jde-1,jte)
8277             DO i = its , MIN(ide-1,ite)
8278                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8279                ht(i,j) = height(i,k850(i,j),j)
8280             END DO
8281          END DO
8282
8283          !  The variable ht is now -ter/ht(850 hPa).  The plot thickens.
8284
8285          DO j = jts , MIN(jde-1,jte)
8286             DO i = its , MIN(ide-1,ite)
8287                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8288                ht(i,j) = -ter(i,j) / ht(i,j)
8289             END DO
8290          END DO
8291
8292          !  Make an isothermal assumption to get a first guess at the surface
8293          !  pressure.  This is to tell us which levels to use for the lapse
8294          !  rates in a bit.
8295
8296          DO j = jts , MIN(jde-1,jte)
8297             DO i = its , MIN(ide-1,ite)
8298                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8299                psfc(i,j) = pslv(i,j) * (pslv(i,j) / p(i,k850(i,j),j)) ** ht(i,j)
8300             END DO
8301          END DO
8302
8303          !  Get a pressure more than pconst Pa above the surface - p1.  The
8304          !  p1 is the top of the level that we will use for our lapse rate
8305          !  computations.
8306
8307          DO j = jts , MIN(jde-1,jte)
8308             DO i = its , MIN(ide-1,ite)
8309                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8310                IF      ( ( psfc(i,j) - 95000. ) .GE. 0. ) THEN
8311                   p1(i,j) = 85000.
8312                ELSE IF ( ( psfc(i,j) - 70000. ) .GE. 0. ) THEN
8313                   p1(i,j) = psfc(i,j) - pconst
8314                ELSE
8315                   p1(i,j) = 50000.
8316                END IF
8317             END DO
8318          END DO
8319
8320          !  Compute virtual temperatures for k850, k700, and k500 layers.  Now
8321          !  you see why we wanted Q on pressure levels, it all is beginning
8322          !  to make sense.
8323
8324          DO j = jts , MIN(jde-1,jte)
8325             DO i = its , MIN(ide-1,ite)
8326                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8327                t850(i,j) = t(i,k850(i,j),j) * (1. + 0.608 * q(i,k850(i,j),j))
8328                t700(i,j) = t(i,k700(i,j),j) * (1. + 0.608 * q(i,k700(i,j),j))
8329                t500(i,j) = t(i,k500(i,j),j) * (1. + 0.608 * q(i,k500(i,j),j))
8330             END DO
8331          END DO
8332
8333          !  Compute lapse rates between these three levels.  These are
8334          !  environmental values for each (i,j).
8335
8336          DO j = jts , MIN(jde-1,jte)
8337             DO i = its , MIN(ide-1,ite)
8338                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8339                gamma78(i,j) = ALOG(t850(i,j) / t700(i,j))  / ALOG (p(i,k850(i,j),j) / p(i,k700(i,j),j) )
8340                gamma57(i,j) = ALOG(t700(i,j) / t500(i,j))  / ALOG (p(i,k700(i,j),j) / p(i,k500(i,j),j) )
8341             END DO
8342          END DO
8343
8344          DO j = jts , MIN(jde-1,jte)
8345             DO i = its , MIN(ide-1,ite)
8346                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8347                IF      ( ( psfc(i,j) - 95000. ) .GE. 0. ) THEN
8348                   t1(i,j) = t850(i,j)
8349                ELSE IF ( ( psfc(i,j) - 85000. ) .GE. 0. ) THEN
8350                   t1(i,j) = t700(i,j) * (p1(i,j) / (p(i,k700(i,j),j))) ** gamma78(i,j)
8351                ELSE IF ( ( psfc(i,j) - 70000. ) .GE. 0.) THEN
8352                   t1(i,j) = t500(i,j) * (p1(i,j) / (p(i,k500(i,j),j))) ** gamma57(i,j)
8353                ELSE
8354                   t1(i,j) = t500(i,j)
8355                ENDIF
8356             END DO
8357          END DO
8358
8359          !  From our temperature way up in the air, we extrapolate down to
8360          !  the sea level to get a guess at the sea level temperature.
8361
8362          DO j = jts , MIN(jde-1,jte)
8363             DO i = its , MIN(ide-1,ite)
8364                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8365                tslv(i,j) = t1(i,j) * (pslv(i,j) / p1(i,j)) ** gammarg
8366             END DO
8367          END DO
8368
8369          !  The new surface temperature is computed from the with new sea level
8370          !  temperature, just using the elevation and a lapse rate.  This lapse
8371          !  rate is -6.5 K/km.
8372
8373          DO j = jts , MIN(jde-1,jte)
8374             DO i = its , MIN(ide-1,ite)
8375                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8376                tsfc(i,j) = tslv(i,j) - gamma * ter(i,j)
8377             END DO
8378          END DO
8379
8380          !  A small correction to the sea-level temperature, in case it is too warm.
8381
8382          DO j = jts , MIN(jde-1,jte)
8383             DO i = its , MIN(ide-1,ite)
8384                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8385                tfixed(i,j) = tc - 0.005 * (tsfc(i,j) - tc) ** 2
8386             END DO
8387          END DO
8388
8389          DO j = jts , MIN(jde-1,jte)
8390             DO i = its , MIN(ide-1,ite)
8391                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8392                l1 = tslv(i,j) .LT. tc
8393                l2 = tsfc(i,j) .LE. tc
8394                l3 = .NOT. l1
8395                IF      ( l2 .AND. l3 ) THEN
8396                   tslv(i,j) = tc
8397                ELSE IF ( ( .NOT. l2 ) .AND. l3 ) THEN
8398                   tslv(i,j) = tfixed(i,j)
8399                END IF
8400             END DO
8401          END DO
8402
8403          !  Finally, we can get to the surface pressure.
8404
8405          DO j = jts , MIN(jde-1,jte)
8406             DO i = its , MIN(ide-1,ite)
8407             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8408             p1(i,j) = - ter(i,j) * g / ( rov2 * ( tsfc(i,j) + tslv(i,j) ) )
8409             psfc(i,j) = pslv(i,j) * EXP ( p1(i,j) )
8410             END DO
8411          END DO
8412
8413       END IF
8414
8415       !  Surface pressure and sea-level pressure are the same at sea level.
8416
8417 !     DO j = jts , MIN(jde-1,jte)
8418 !        DO i = its , MIN(ide-1,ite)
8419 !           IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8420 !           IF ( ABS ( ter(i,j) )  .LT. 0.1 ) THEN
8421 !              psfc(i,j) = pslv(i,j)
8422 !           END IF
8423 !        END DO
8424 !     END DO
8425
8426    END SUBROUTINE sfcprs
8427
8428 !---------------------------------------------------------------------
8429
8430    SUBROUTINE sfcprs2(t, q, height, psfc_in, ter, avgsfct, p, &
8431                       psfc, ez_method, &
8432                       ids , ide , jds , jde , kds , kde , &
8433                       ims , ime , jms , jme , kms , kme , &
8434                       its , ite , jts , jte , kts , kte )
8435
8436
8437       !  Computes the surface pressure using the input height,
8438       !  temperature and q (already computed from relative
8439       !  humidity) on p surfaces.  Sea level pressure is used
8440       !  to extrapolate a first guess.
8441
8442       IMPLICIT NONE
8443
8444       REAL, PARAMETER    :: Rd        = r_d
8445
8446       INTEGER , INTENT(IN) ::  ids , ide , jds , jde , kds , kde , &
8447                                ims , ime , jms , jme , kms , kme , &
8448                                its , ite , jts , jte , kts , kte
8449       LOGICAL , INTENT ( IN ) :: ez_method
8450
8451       REAL , DIMENSION (ims:ime,kms:kme,jms:jme) , INTENT(IN ):: t, q, height, p
8452       REAL , DIMENSION (ims:ime,        jms:jme) , INTENT(IN ):: psfc_in ,  ter, avgsfct
8453       REAL , DIMENSION (ims:ime,        jms:jme) , INTENT(OUT):: psfc
8454
8455       INTEGER                     :: i
8456       INTEGER                     :: j
8457       INTEGER                     :: k
8458
8459       REAL :: tv_sfc_avg , tv_sfc , del_z
8460
8461       !  Compute the new surface pressure from the old surface pressure, and a
8462       !  known change in elevation at the surface.
8463
8464       !  del_z = diff in surface topo, lo-res vs hi-res
8465       !  psfc = psfc_in * exp ( g del_z / (Rd Tv_sfc ) )
8466
8467
8468       IF ( ez_method ) THEN
8469          DO j = jts , MIN(jde-1,jte)
8470             DO i = its , MIN(ide-1,ite)
8471                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8472                tv_sfc_avg = avgsfct(i,j) * (1. + 0.608 * q(i,1,j))
8473                del_z = height(i,1,j) - ter(i,j)
8474                psfc(i,j) = psfc_in(i,j) * EXP ( g * del_z / ( Rd * tv_sfc_avg ) )
8475             END DO
8476          END DO
8477       ELSE
8478          DO j = jts , MIN(jde-1,jte)
8479             DO i = its , MIN(ide-1,ite)
8480                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8481                tv_sfc = t(i,1,j) * (1. + 0.608 * q(i,1,j))
8482                del_z = height(i,1,j) - ter(i,j)
8483                psfc(i,j) = psfc_in(i,j) * EXP ( g * del_z / ( Rd * tv_sfc     ) )
8484             END DO
8485          END DO
8486       END IF
8487
8488    END SUBROUTINE sfcprs2
8489
8490 !---------------------------------------------------------------------
8491
8492    SUBROUTINE sfcprs3( height , p , ter , slp , psfc , &
8493                        ids , ide , jds , jde , kds , kde , &
8494                        ims , ime , jms , jme , kms , kme , &
8495                        its , ite , jts , jte , kts , kte )
8496
8497       !  Computes the surface pressure by vertically interpolating
8498       !  linearly (or log) in z the pressure, to the targeted topography.
8499
8500       IMPLICIT NONE
8501
8502       INTEGER , INTENT(IN) ::  ids , ide , jds , jde , kds , kde , &
8503                                ims , ime , jms , jme , kms , kme , &
8504                                its , ite , jts , jte , kts , kte
8505
8506       REAL , DIMENSION (ims:ime,kms:kme,jms:jme) , INTENT(IN ):: height, p
8507       REAL , DIMENSION (ims:ime,        jms:jme) , INTENT(IN ):: ter , slp
8508       REAL , DIMENSION (ims:ime,        jms:jme) , INTENT(OUT):: psfc
8509
8510       INTEGER                     :: i
8511       INTEGER                     :: j
8512       INTEGER                     :: k
8513
8514       LOGICAL                     :: found_loc
8515
8516       REAL :: zl , zu , pl , pu , zm
8517
8518       !  Loop over each grid point
8519
8520       DO j = jts , MIN(jde-1,jte)
8521          DO i = its , MIN(ide-1,ite)
8522             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8523
8524             !  Special case where near the ocean level.  Assume that the SLP is a good value.
8525
8526             IF      ( ter(i,j) .LT. 50 ) THEN
8527                psfc(i,j) = slp(i,j) + ( p(i,2,j)-p(i,3,j) ) / ( height(i,2,j)-height(i,3,j) ) * ter(i,j)
8528                CYCLE
8529             END IF
8530
8531             !  Find the trapping levels
8532
8533             found_loc = .FALSE.
8534
8535             !  Normal sort of scenario - the model topography is somewhere between
8536             !  the height values of 1000 mb and the top of the model.
8537
8538             found_k_loc : DO k = kts+1 , kte-2
8539                IF ( ( height(i,k  ,j) .LE. ter(i,j) ) .AND. &
8540                     ( height(i,k+1,j) .GT. ter(i,j) ) ) THEN
8541                   zl = height(i,k  ,j)
8542                   zu = height(i,k+1,j)
8543                   zm = ter(i,j)
8544                   pl = p(i,k  ,j)
8545                   pu = p(i,k+1,j)
8546                   psfc(i,j) = EXP ( ( LOG(pl) * ( zm - zu ) + LOG(pu) * ( zl - zm ) ) / ( zl - zu ) )
8547                   found_loc = .TRUE.
8548                   EXIT found_k_loc
8549                END IF
8550             END DO found_k_loc
8551
8552             !  Interpolate betwixt slp and the first isobaric level above - this is probably the
8553             !  usual thing over the ocean.
8554
8555             IF ( .NOT. found_loc ) THEN
8556                IF ( slp(i,j) .GE. p(i,2,j) ) THEN
8557                   zl = 0.
8558                   zu = height(i,3,j)
8559                   zm = ter(i,j)
8560                   pl = slp(i,j)
8561                   pu = p(i,3,j)
8562                   psfc(i,j) = EXP ( ( LOG(pl) * ( zm - zu ) + LOG(pu) * ( zl - zm ) ) / ( zl - zu ) )
8563                   found_loc = .TRUE.
8564                ELSE
8565                   found_slp_loc : DO k = kts+1 , kte-3
8566                      IF ( ( slp(i,j) .GE. p(i,k+1,j) ) .AND. &
8567                           ( slp(i,j) .LT. p(i,k  ,j) ) ) THEN
8568                         zl = 0.
8569                         zu = height(i,k+1,j)
8570                         zm = ter(i,j)
8571                         pl = slp(i,j)
8572                         pu = p(i,k+1,j)
8573                         psfc(i,j) = EXP ( ( LOG(pl) * ( zm - zu ) + LOG(pu) * ( zl - zm ) ) / ( zl - zu ) )
8574                         found_loc = .TRUE.
8575                         EXIT found_slp_loc
8576                      END IF
8577                   END DO found_slp_loc
8578                END IF
8579             END IF
8580
8581             !  Did we do what we wanted done.
8582
8583             IF ( .NOT. found_loc ) THEN
8584                print *,'i,j = ',i,j
8585                print *,'p column = ',p(i,2:,j)
8586                print *,'z column = ',height(i,2:,j)
8587                print *,'model topo = ',ter(i,j)
8588                CALL wrf_error_fatal ( ' probs with sfc p computation ' )
8589             END IF
8590
8591          END DO
8592       END DO
8593
8594    END SUBROUTINE sfcprs3
8595
8596 !---------------------------------------------------------------------
8597
8598    SUBROUTINE filter_topo ( ht_in , xlat , msftx , &
8599                             fft_filter_lat , mf_fft , &
8600                             pos_def , swap_pole_with_next_j , &
8601                             ids , ide , jds , jde , kds , kde , &
8602                             ims , ime , jms , jme , kms , kme , &
8603                             its , ite , jts , jte , kts , kte )
8604
8605       IMPLICIT NONE
8606
8607       INTEGER , INTENT(IN) ::  ids , ide , jds , jde , kds , kde , &
8608                                ims , ime , jms , jme , kms , kme , &
8609                                its , ite , jts , jte , kts , kte
8610
8611       REAL , INTENT(IN) :: fft_filter_lat , mf_fft
8612       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: ht_in
8613       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: xlat , msftx
8614       LOGICAL :: pos_def , swap_pole_with_next_j
8615
8616       !  Local vars
8617
8618       INTEGER :: i , j , j_lat_pos , j_lat_neg , k
8619       INTEGER :: i_kicker , ik , i1, i2, i3, i4
8620       INTEGER :: i_left , i_right , ii
8621       REAL :: length_scale , sum
8622       REAL , DIMENSION(its:ite,jts:jte) :: ht_out
8623       CHARACTER (LEN=256) :: message
8624
8625       !  The filtering is a simple average on a latitude loop.  Possibly a LONG list of
8626       !  numbers.  We assume that ALL of the 2d arrays have been transposed so that
8627       !  each patch has the entire domain size of the i-dim local.
8628
8629       IF ( ( its .NE. ids ) .OR. ( ite .NE. ide ) ) THEN
8630          CALL wrf_error_fatal ( 'filtering assumes all values on X' )
8631       END IF
8632
8633       !  Starting at the south pole, we find where the
8634       !  grid distance is big enough, then go back a point.  Continuing to the
8635       !  north pole, we find the first small grid distance.  These are the
8636       !  computational latitude loops and the associated computational poles.
8637
8638       j_lat_neg = 0
8639       j_lat_pos = jde + 1
8640       loop_neg : DO j = MIN(jde-1,jte) , jts , -1
8641          IF ( xlat(its,j) .LT. 0.0 ) THEN
8642             IF ( ABS(xlat(its,j)) .GE. fft_filter_lat ) THEN
8643                j_lat_neg = j
8644                EXIT loop_neg
8645             END IF
8646          END IF
8647       END DO loop_neg
8648
8649       loop_pos : DO j = jts , MIN(jde-1,jte)
8650          IF ( xlat(its,j) .GT. 0.0 ) THEN
8651             IF ( xlat(its,j) .GE. fft_filter_lat ) THEN
8652                j_lat_pos = j
8653                EXIT loop_pos
8654             END IF
8655          END IF
8656       END DO loop_pos
8657
8658       !  Set output values to initial input topo values for whole patch.
8659
8660       DO j = jts , MIN(jde-1,jte)
8661          DO i = its , MIN(ide-1,ite)
8662             ht_out(i,j) = ht_in(i,j)
8663          END DO
8664       END DO
8665
8666       !  Filter the topo at the negative lats.
8667
8668       DO j = MIN(j_lat_neg,jte) , jts , -1
8669 !        i_kicker = MIN( MAX ( NINT(msftx(its,j)/2) , 1 ) , (ide - ids) / 2 )
8670          i_kicker = MIN( MAX ( NINT(msftx(its,j)/mf_fft/2) , 1 ) , (ide - ids) / 2 )
8671          WRITE (message,*) 'SOUTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j)
8672          CALL wrf_debug(10,TRIM(message))
8673          DO i = its , MIN(ide-1,ite)
8674             sum = 0.
8675             DO ik = 1 , i_kicker
8676                ii = i-ik
8677                IF ( ii .GE. ids ) THEN
8678                   i_left = ii
8679                ELSE
8680                   i_left = ( ii - ids ) + (ide-1)+1
8681                END IF
8682                ii = i+ik
8683                IF ( ii .LE. ide-1 ) THEN
8684                   i_right = ii
8685                ELSE
8686                   i_right = ( ii - (ide-1) ) + its-1
8687                END IF
8688                sum = sum + ht_in(i_left,j) + ht_in(i_right,j)
8689             END DO
8690             ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8691          END DO
8692       END DO
8693
8694       !  Filter the topo at the positive lats.
8695
8696       DO j = MAX(j_lat_pos,jts) , MIN(jde-1,jte)
8697 !        i_kicker = MIN( MAX ( NINT(msftx(its,j)/2) , 1 ) , (ide - ids) / 2 )
8698          i_kicker = MIN( MAX ( NINT(msftx(its,j)/mf_fft/2) , 1 ) , (ide - ids) / 2 )
8699          WRITE (message,*) 'NORTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j)
8700          CALL wrf_debug(10,TRIM(message))
8701          DO i = its , MIN(ide-1,ite)
8702             sum = 0.
8703             DO ik = 1 , i_kicker
8704                ii = i-ik
8705                IF ( ii .GE. ids ) THEN
8706                   i_left = ii
8707                ELSE
8708                   i_left = ( ii - ids ) + (ide-1)+1
8709                END IF
8710                ii = i+ik
8711                IF ( ii .LE. ide-1 ) THEN
8712                   i_right = ii
8713                ELSE
8714                   i_right = ( ii - (ide-1) ) + its-1
8715                END IF
8716                sum = sum + ht_in(i_left,j) + ht_in(i_right,j)
8717             END DO
8718             ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8719          END DO
8720       END DO
8721
8722       !  Set output values to initial input topo values for whole patch.
8723
8724       DO j = jts , MIN(jde-1,jte)
8725          DO i = its , MIN(ide-1,ite)
8726             ht_in(i,j) = ht_out(i,j)
8727          END DO
8728       END DO
8729
8730    END SUBROUTINE filter_topo
8731
8732 !---------------------------------------------------------------------
8733 !---------------------------------------------------------------------
8734
8735    SUBROUTINE filter_topo_old ( ht_in , xlat , msftx , fft_filter_lat , &
8736                             dummy , &
8737                             ids , ide , jds , jde , kds , kde , &
8738                             ims , ime , jms , jme , kms , kme , &
8739                             its , ite , jts , jte , kts , kte )
8740
8741       IMPLICIT NONE
8742
8743       INTEGER , INTENT(IN) ::  ids , ide , jds , jde , kds , kde , &
8744                                ims , ime , jms , jme , kms , kme , &
8745                                its , ite , jts , jte , kts , kte
8746
8747       REAL , INTENT(IN) :: fft_filter_lat , dummy
8748       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: ht_in
8749       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: xlat , msftx
8750
8751
8752       !  Local vars
8753
8754       INTEGER :: i , j , j_lat_pos , j_lat_neg
8755       INTEGER :: i_kicker , ik , i1, i2, i3, i4
8756       REAL :: length_scale , sum
8757       REAL , DIMENSION(its:ite,jts:jte) :: ht_out
8758
8759       !  The filtering is a simple average on a latitude loop.  Possibly a LONG list of
8760       !  numbers.  We assume that ALL of the 2d arrays have been transposed so that
8761       !  each patch has the entire domain size of the i-dim local.
8762
8763       IF ( ( its .NE. ids ) .OR. ( ite .NE. ide ) ) THEN
8764          CALL wrf_error_fatal ( 'filtering assumes all values on X' )
8765       END IF
8766
8767       !  Starting at the south pole, we find where the
8768       !  grid distance is big enough, then go back a point.  Continuing to the
8769       !  north pole, we find the first small grid distance.  These are the
8770       !  computational latitude loops and the associated computational poles.
8771
8772       j_lat_neg = 0
8773       j_lat_pos = jde + 1
8774       loop_neg : DO j = jts , MIN(jde-1,jte)
8775          IF ( xlat(its,j) .LT. 0.0 ) THEN
8776             IF ( ABS(xlat(its,j)) .LT. fft_filter_lat ) THEN
8777                j_lat_neg = j - 1
8778                EXIT loop_neg
8779             END IF
8780          END IF
8781       END DO loop_neg
8782
8783       loop_pos : DO j = jts , MIN(jde-1,jte)
8784          IF ( xlat(its,j) .GT. 0.0 ) THEN
8785             IF ( xlat(its,j) .GE. fft_filter_lat ) THEN
8786                j_lat_pos = j
8787                EXIT loop_pos
8788             END IF
8789          END IF
8790       END DO loop_pos
8791
8792       !  Set output values to initial input topo values for whole patch.
8793
8794       DO j = jts , MIN(jde-1,jte)
8795          DO i = its , MIN(ide-1,ite)
8796             ht_out(i,j) = ht_in(i,j)
8797          END DO
8798       END DO
8799
8800       !  Filter the topo at the negative lats.
8801
8802       DO j = j_lat_neg , jts , -1
8803          i_kicker = MIN( MAX ( NINT(msftx(its,j)) , 1 ) , (ide - ids) / 2 )
8804          print *,'j = ' , j, ', kicker = ',i_kicker
8805          DO i = its , MIN(ide-1,ite)
8806             IF      ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN
8807                sum = 0.0
8808                DO ik = 1 , i_kicker
8809                   sum = sum + ht_in(i+ik,j) + ht_in(i-ik,j)
8810                END DO
8811                ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8812             ELSE IF ( ( i - i_kicker .LT. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN
8813                sum = 0.0
8814                DO ik = 1 , i_kicker
8815                   sum = sum + ht_in(i+ik,j)
8816                END DO
8817                i1 = i - i_kicker + ide -1
8818                i2 = ide-1
8819                i3 = ids
8820                i4 = i-1
8821                DO ik = i1 , i2
8822                   sum = sum + ht_in(ik,j)
8823                END DO
8824                DO ik = i3 , i4
8825                   sum = sum + ht_in(ik,j)
8826                END DO
8827                ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8828             ELSE IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .GT. ide-1 ) ) THEN
8829                sum = 0.0
8830                DO ik = 1 , i_kicker
8831                   sum = sum + ht_in(i-ik,j)
8832                END DO
8833                i1 = i+1
8834                i2 = ide-1
8835                i3 = ids
8836                i4 = ids + ( i_kicker+i ) - ide
8837                DO ik = i1 , i2
8838                   sum = sum + ht_in(ik,j)
8839                END DO
8840                DO ik = i3 , i4
8841                   sum = sum + ht_in(ik,j)
8842                END DO
8843                ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8844             END IF
8845          END DO
8846       END DO
8847
8848       !  Filter the topo at the positive lats.
8849
8850       DO j = j_lat_pos , MIN(jde-1,jte)
8851          i_kicker = MIN( MAX ( NINT(msftx(its,j)) , 1 ) , (ide - ids) / 2 )
8852          print *,'j = ' , j, ', kicker = ',i_kicker
8853          DO i = its , MIN(ide-1,ite)
8854             IF      ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN
8855                sum = 0.0
8856                DO ik = 1 , i_kicker
8857                   sum = sum + ht_in(i+ik,j) + ht_in(i-ik,j)
8858                END DO
8859                ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8860             ELSE IF ( ( i - i_kicker .LT. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN
8861                sum = 0.0
8862                DO ik = 1 , i_kicker
8863                   sum = sum + ht_in(i+ik,j)
8864                END DO
8865                i1 = i - i_kicker + ide -1
8866                i2 = ide-1
8867                i3 = ids
8868                i4 = i-1
8869                DO ik = i1 , i2
8870                   sum = sum + ht_in(ik,j)
8871                END DO
8872                DO ik = i3 , i4
8873                   sum = sum + ht_in(ik,j)
8874                END DO
8875                ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8876             ELSE IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .GT. ide-1 ) ) THEN
8877                sum = 0.0
8878                DO ik = 1 , i_kicker
8879                   sum = sum + ht_in(i-ik,j)
8880                END DO
8881                i1 = i+1
8882                i2 = ide-1
8883                i3 = ids
8884                i4 = ids + ( i_kicker+i ) - ide
8885                DO ik = i1 , i2
8886                   sum = sum + ht_in(ik,j)
8887                END DO
8888                DO ik = i3 , i4
8889                   sum = sum + ht_in(ik,j)
8890                END DO
8891                ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8892             END IF
8893          END DO
8894       END DO
8895
8896       !  Set output values to initial input topo values for whole patch.
8897
8898       DO j = jts , MIN(jde-1,jte)
8899          DO i = its , MIN(ide-1,ite)
8900             ht_in(i,j) = ht_out(i,j)
8901          END DO
8902       END DO
8903
8904    END SUBROUTINE filter_topo_old
8905
8906 !---------------------------------------------------------------------
8907
8908
8909 !+---+-----------------------------------------------------------------+
8910 ! Begin addition by Greg Thompson to dry out the stratosphere.
8911 ! Starting 3 levels below model top, go downward and search for where
8912 ! Theta gradient over three K-levels is less steep than +10 K per 1500 m.
8913 ! This threshold approximates a vertical line on a skew-T chart from
8914 ! approximately 300 to 240 mb, anything more unstable than this reference
8915 ! is probably in the troposphere so pick the K plus 1 point as the
8916 ! tropopause and set mixing ratio to a really small values above.
8917 !..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805
8918 !..Last modified: 30 Dec 2004
8919 !+---+-----------------------------------------------------------------+
8920
8921    subroutine dry_stratos ( theta, qv, phb, &
8922                             ids , ide , jds , jde , kds , kde , &
8923                             ims , ime , jms , jme , kms , kme , &
8924                             its , ite , jts , jte , kts , kte )
8925
8926       IMPLICIT NONE
8927
8928       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
8929                                      ims , ime , jms , jme , kms , kme , &
8930                                      its , ite , jts , jte , kts , kte
8931
8932       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN)     :: theta, phb
8933       REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT)  :: qv
8934
8935       !  Local vars
8936
8937       INTEGER :: i, j, k, kk, istart, iend, jstart, jend, kstart, kend
8938       REAL    :: ht1, ht2, theta1, theta2, htz, sat85, p_std_atmos
8939       CHARACTER*256:: str_debug
8940       ! Saturation vapor pressure at T = -85C.
8941       DATA sat85 /0.0235755574/
8942
8943       do i = 1, 256
8944          str_debug(i:i) = char(0)
8945       enddo
8946
8947       istart = its
8948       iend   = MIN(ide-1,ite)
8949       jstart = jts
8950       jend   = MIN(jde-1,jte)
8951       kstart = kts
8952       kend   = kte-1
8953       DO j = jstart, jend
8954          DO i = istart, iend
8955             DO k = kend-3, kstart, -1
8956                ht1 = phb(i,k,j)/9.8
8957                ht2 = phb(i,k+2,j)/9.8
8958                theta1 = theta(i,k,j)
8959                theta2 = theta(i,k+2,j)
8960                if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. (ht1.gt.4000.) ) then
8961                   DO kk = k+3, kend
8962                      htz = phb(i,kk,j)/9.8
8963                      p_std_atmos = exp(log(1.0-htz/44307.692)/0.19)*101325.0
8964                      qv(i,kk,j) = 0.622*sat85/(p_std_atmos-sat85)
8965                   END DO
8966                   goto 79
8967                end if
8968             END DO
8969  79         continue
8970          END DO
8971       END DO
8972
8973    END SUBROUTINE dry_stratos
8974
8975 !+---+-----------------------------------------------------------------+
8976 !..Hardwire snow cover above a pre-specified altitude.
8977 !.. Starting altitude for snow (snow_startz) depends on latitude
8978 !.. and is 3900 m at 35-deg lowering to 250km (linearly) by 65-deg lat.
8979 !.. Alter WEASD linear function from 0 at snow_startz to 999 mm at 4 km.
8980 !.. Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805
8981 !.. Last modified: 27 Dec 2008
8982 !+---+-----------------------------------------------------------------+
8983
8984       real function snowHires (snow_in, latitude, elev, date_str, i,j)
8985       IMPLICIT NONE
8986
8987       REAL, INTENT(IN):: latitude, elev, snow_in
8988       INTEGER, INTENT(IN):: i, j
8989       CHARACTER (LEN=24), INTENT(IN) :: date_str
8990
8991       REAL :: snow_startz, del_lat, season_factor, snow_out
8992       REAL :: gmt
8993       INTEGER :: day_peak, day_of_year, julyr
8994       CHARACTER (LEN=256) :: dbg_msg
8995
8996       CALL get_julgmt ( date_str , julyr , day_of_year , gmt )
8997
8998       if (latitude .gt. 0.0) then
8999          del_lat = (65.-latitude)/(65.-35.)
9000          day_peak = 80
9001       else
9002          del_lat = (-65.-latitude)/(-65.+35.)
9003          day_peak = 264
9004       endif
9005
9006       snow_startz = (3900.-250.)*del_lat + 250.
9007       snow_startz = max(250., min(3900., snow_startz))
9008
9009       season_factor = 1.
9010       snow_out = 0.
9011       IF (elev .GT. snow_startz) THEN
9012          season_factor = ABS(COS((day_of_year - day_peak)*0.5*0.0174533))
9013          snow_out = 0.999*(elev-snow_startz)/(4000.-snow_startz)
9014          write(dbg_msg,*) 'DEBUG_GT_SNOW ', day_of_year, latitude, elev, snow_in, snow_startz, season_factor, snow_out,i, j
9015          CALL wrf_debug (150, dbg_msg)
9016       ENDIF
9017
9018       snowHires = MAX(snow_in, season_factor * snow_out)
9019
9020       END FUNCTION snowHires
9021
9022 !+---+-----------------------------------------------------------------+
9023 !+---+-----------------------------------------------------------------+
9024
9025       real function make_IceNumber (Q_ice, temp)
9026
9027       IMPLICIT NONE
9028       REAL, PARAMETER:: Ice_density = 890.0
9029       REAL, PARAMETER:: PI = 3.1415926536
9030       integer idx_rei
9031       real corr, reice, deice, Q_ice, temp
9032       double precision lambda
9033
9034 !+---+-----------------------------------------------------------------+
9035 !..Table of lookup values of radiative effective radius of ice crystals
9036 !.. as a function of Temperature from -94C to 0C.  Taken from WRF RRTMG
9037 !.. radiation code where it is attributed to Jon Egill Kristjansson
9038 !.. and coauthors.
9039 !+---+-----------------------------------------------------------------+
9040
9041       real retab(95)
9042       data retab /                                                      &
9043          5.92779, 6.26422, 6.61973, 6.99539, 7.39234,                   &
9044          7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930,          &
9045          10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319,          &
9046          15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955,          &
9047          20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125,          &
9048          27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943,          &
9049          31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601,          &
9050          34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078,          &
9051          38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635,          &
9052          42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221,          &
9053          50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898,          &
9054          65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833,          &
9055          93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424,          &
9056          124.954, 130.630, 136.457, 142.446, 148.608, 154.956,          &
9057          161.503, 168.262, 175.248, 182.473, 189.952, 197.699,          &
9058          205.728, 214.055, 222.694, 231.661, 240.971, 250.639/
9059
9060 !+---+-----------------------------------------------------------------+
9061 !..From the model 3D temperature field, subtract 179K for which
9062 !.. index value of retab as a start.  Value of corr is for
9063 !.. interpolating between neighboring values in the table.
9064 !+---+-----------------------------------------------------------------+
9065
9066       idx_rei = int(temp-179.)
9067       idx_rei = min(max(idx_rei,1),94)
9068       corr = temp - int(temp)
9069       reice = retab(idx_rei)*(1.-corr) + retab(idx_rei+1)*corr
9070       deice = 2.*reice * 1.E-6
9071
9072 !+---+-----------------------------------------------------------------+
9073 !..Now we have the final radiative effective size of ice (as function
9074 !.. of temperature only).  This size represents 3rd moment divided by
9075 !.. second moment of the ice size distribution, so we can compute a
9076 !.. number concentration from the mean size and mass mixing ratio.
9077 !.. The mean (radiative effective) diameter is 3./Slope for an inverse
9078 !.. exponential size distribution.  So, starting with slope, work
9079 !.. backwords to get number concentration.
9080 !+---+-----------------------------------------------------------------+
9081
9082       lambda = 3.0 / deice
9083       make_IceNumber = Q_ice * lambda*lambda*lambda / (PI*Ice_density)
9084
9085 !+---+-----------------------------------------------------------------+
9086 !..Example1: Common ice size coming from Thompson scheme is about 30 microns.
9087 !.. An example ice mixing ratio could be 0.001 g/kg for a temperature of -50C.
9088 !.. Remember to convert both into MKS units.  This gives N_ice=357652 per kg.
9089 !..Example2: Lower in atmosphere at T=-10C matching ~162 microns in retab,
9090 !.. and assuming we have 0.1 g/kg mixing ratio, then N_ice=28122 per kg,
9091 !.. which is 28 crystals per liter of air if the air density is 1.0.
9092 !+---+-----------------------------------------------------------------+
9093
9094       return
9095       end function make_IceNumber
9096
9097 !+---+-----------------------------------------------------------------+
9098 !+---+-----------------------------------------------------------------+
9099
9100       real function make_DropletNumber (Q_cloud, qnwfa, xland)
9101
9102       IMPLICIT NONE
9103
9104       real:: Q_cloud, qnwfa, xland
9105
9106       real, parameter:: PI = 3.1415926536
9107       real, parameter:: am_r = PI*1000./6.
9108       real, dimension(15), parameter:: g_ratio = (/24,60,120,210,336,   &
9109      &                504,720,990,1320,1716,2184,2730,3360,4080,4896/)
9110       double precision:: lambda, qnc
9111       real:: q_nwfa, x1, xDc
9112       integer:: nu_c
9113
9114 !+---+
9115
9116       if (qnwfa .le. 0.0) then
9117
9118          if ((xland-1.5).gt.0.) then                                     !--- Ocean
9119             xDc = 17.E-6
9120             nu_c = 12
9121          else                                                            !--- Land
9122             xDc = 11.E-6
9123             nu_c = 4
9124          endif
9125
9126       else
9127          q_nwfa = MAX(99.E6, MIN(qnwfa,5.E10))
9128          nu_c = MAX(2, MIN(NINT(2.5E10/q_nwfa), 15))
9129
9130          x1 = MAX(1., MIN(q_nwfa*1.E-9, 10.)) - 1.
9131          xDc = (30. - x1*20./9.) * 1.E-6
9132       endif
9133
9134       lambda = (4.0D0 + nu_c) / xDc
9135       qnc = Q_cloud / g_ratio(nu_c) * lambda*lambda*lambda / am_r
9136       make_DropletNumber = SNGL(qnc)
9137
9138       return
9139       end function make_DropletNumber
9140
9141 !+---+-----------------------------------------------------------------+
9142 !+---+-----------------------------------------------------------------+
9143
9144       real function make_RainNumber (Q_rain, temp)
9145
9146       IMPLICIT NONE
9147
9148       real, intent(in):: Q_rain, temp
9149       double precision:: lambda, N0, qnr
9150       real, parameter:: PI = 3.1415926536
9151       real, parameter:: am_r = PI*1000./6.
9152
9153       !+---+-----------------------------------------------------------------+
9154       !.. Not thrilled with it, but set Y-intercept parameter to Marshal-Palmer value
9155       !.. that basically assumes melting snow becomes typical rain. However, for
9156       !.. -2C < T < 0C, make linear increase in exponent to attempt to keep
9157       !.. supercooled collision-coalescence (warm-rain) similar to drizzle rather
9158       !.. than bigger rain drops.  While this could also exist at T>0C, it is
9159       !.. more difficult to assume it directly from having mass and not number.
9160       !+---+-----------------------------------------------------------------+
9161
9162       N0 = 8.E6
9163
9164       if (temp .le. 271.15) then
9165          N0 = 8.E8
9166       elseif (temp .gt. 271.15 .and. temp.lt.273.15) then
9167          N0 = 8. * 10**(279.15-temp)
9168       endif
9169
9170       lambda = SQRT(SQRT(N0*am_r*6.0/Q_rain))
9171       qnr = Q_rain / 6.0 * lambda*lambda*lambda / am_r
9172       make_RainNumber = SNGL(qnr)
9173
9174       return
9175       end function make_RainNumber
9176
9177 !+---+-----------------------------------------------------------------+
9178 !+---+-----------------------------------------------------------------+
9179
9180
9181    SUBROUTINE init_module_initialize
9182    END SUBROUTINE init_module_initialize
9183
9184 !---------------------------------------------------------------------
9185
9186 END MODULE module_initialize_real
9187 #endif