frame/module_configure.F

   1 !WRF:DRIVER_LAYER:CONFIGURATION
   2 !
   3
   4 MODULE module_scalar_tables
   5   USE module_driver_constants
   6   USE module_state_description
   7   USE module_domain_type, ONLY : streamrec
   8 #include "scalar_tables.inc"
   9 CONTAINS
  10   SUBROUTINE init_module_scalar_tables
  11      INTEGER i , j
  12      DO j = 1, max_domains
  13 #include "scalar_tables_init.inc"
  14      END DO
  15   END SUBROUTINE init_module_scalar_tables
  16 END MODULE module_scalar_tables
  17
  18 #if( WRF_CHEM == 1 && WRF_KPP == 1 )
  19 MODULE module_irr_diag
  20
  21    INTEGER, parameter :: max_eqn = 1200
  22    INTEGER :: max_dom
  23    INTEGER, ALLOCATABLE :: irr_diag_cnt(:)
  24    INTEGER, ALLOCATABLE :: irr_diag_ndx(:,:)
  25    LOGICAL, ALLOCATABLE :: irr_option(:)
  26    LOGICAL, ALLOCATABLE :: irr_active(:)
  27
  28 CONTAINS
  29
  30   SUBROUTINE init_module_irr_diag
  31
  32     INTEGER :: astat
  33
  34     IF( .not. ALLOCATED( irr_option ) ) THEN
  35       CALL nl_get_max_dom( 1, max_dom )
  36       ALLOCATE( irr_option(max_dom),irr_active(max_dom),irr_diag_ndx(max_eqn,max_dom),irr_diag_cnt(max_dom),stat=astat )
  37       IF( astat /= 0 ) THEN
  38         CALL wrf_error_fatal( "init_module_irr_diag: Failed to allocate irr_option ... irr_diag_cnt" )
  39       ENDIF
  40       irr_option(:) = .false.
  41       irr_active(:) = .false.
  42     ENDIF
  43
  44   END SUBROUTINE init_module_irr_diag
  45
  46 END MODULE module_irr_diag
  47 #endif
  48
  49 MODULE module_configure
  50
  51    USE module_driver_constants
  52    USE module_state_description
  53    USE module_wrf_error
  54
  55    TYPE model_config_rec_type
  56       SEQUENCE
  57 ! Statements that declare namelist variables are in this file
  58 ! Note that the namelist is SEQUENCE and generated such that the first item is an
  59 ! integer, first_item_in_struct and the last is an integer last_item_in_struct
  60 ! this provides a way of converting this to a buffer for passing to and from
  61 ! the driver.
  62 #include "namelist_defines.inc"
  63    END TYPE model_config_rec_type
  64
  65    TYPE grid_config_rec_type
  66 #include "namelist_defines2.inc"
  67    END TYPE grid_config_rec_type
  68
  69    TYPE(model_config_rec_type) :: model_config_rec
  70
  71 !#include "scalar_tables.inc"
  72
  73 ! special entries (put here but not enshrined in Registry for one reason or other)
  74
  75 !   CHARACTER (LEN=256) :: mminlu = ' '             ! character string for landuse table
  76
  77 CONTAINS
  78
  79
  80 ! Model layer, even though it does I/O -- special case of namelist I/O.
  81
  82    SUBROUTINE initial_config
  83 !<DESCRIPTION>
  84 ! This routine reads in the namelist.input file and sets
  85 ! module_config_rec, a structure of TYPE(model_config_rec_type), which is is seen via USE association by any
  86 ! subprogram that uses module_configure.  The module_config_rec structure
  87 ! contains all namelist settings for all domains.  Variables that apply
  88 ! to the entire run and have only one value regardless of domain are
  89 ! scalars.  Variables that allow different settings for each domain are
  90 ! defined as arrays of dimension max_domains (defined in
  91 ! frame/module_driver_constants.F, from a setting passed in from
  92 ! configure.wrf). There is another type in WRF, TYPE(grid_config_rec_type), in which
  93 ! all fields pertain only to a single domain (and are all scalars). The subroutine
  94 ! model_to_grid_config_rec(), also in frame/module_configure.F, is used to retrieve
  95 ! the settings for a given domain from a TYPE(module_config_rec_type) and put them into
  96 ! a TYPE(grid_config_rec_type), variables of which type are often called <em>config_flags</em>
  97 ! in the WRF code.
  98 !
  99 ! Most of the code in this routine is generated from the Registry file
 100 ! rconfig entries and included from the following files (found in the inc directory):
 101 !
 102 ! <pre>
 103 ! namelist_defines.inc  declarations of namelist variables (local to this routine)
 104 ! namelist_statements.inc       NAMELIST statements for each variable
 105 ! namelist_defaults.inc assignment to default values if specified in Registry
 106 ! config_reads.inc              read statements for each namelist record
 107 ! config_assigns.inc    assign each variable to field in module_config_rec
 108 ! </pre>
 109 !
 110 !NOTE: generated subroutines from Registry file rconfig entries are renamed nl_
 111 ! instead of rconfig_ due to length limits for subroutine names.
 112 !
 113 ! Note for version WRF 2.0: there is code here to force all domains to
 114 ! have the same mp_physics setting. This is because different mp_physics
 115 ! packages have different numbers of tracers but the nest forcing and
 116 ! feedback code relies on the parent and nest having the same number and
 117 ! kind of tracers. This means that the microphysics option
 118 ! specified on the highest numbered domain is the microphysics
 119 ! option for <em>all</em> domains in the run. This will be revisited.
 120 !
 121 !</DESCRIPTION>
 122       IMPLICIT NONE
 123
 124       INTEGER              :: io_status
 125       INTEGER              :: i
 126
 127       LOGICAL              :: nml_read_error
 128
 129       CHARACTER (LEN=1024) :: nml_name
 130
 131       INTEGER, PARAMETER :: nml_write_unit= 9
 132       INTEGER, PARAMETER :: nml_read_unit = 10
 133
 134       CHARACTER (LEN=1024) :: entire_line
 135
 136
 137 ! define as temporaries
 138 #include "namelist_defines.inc"
 139
 140 ! Statements that specify the namelists
 141 #include "namelist_statements.inc"
 142
 143       OPEN ( UNIT   = nml_read_unit    ,      &
 144              FILE   = "namelist.input" ,      &
 145              FORM   = "FORMATTED"      ,      &
 146              STATUS = "OLD"            ,      &
 147              IOSTAT = io_status         )
 148
 149       IF ( io_status .NE. 0 ) THEN
 150         CALL WRF_ERROR_FATAL ( 'ERROR OPENING namelist.input' )
 151       ENDIF
 152
 153 #ifndef NO_NAMELIST_PRINT
 154       OPEN ( UNIT   = nml_write_unit    ,      &
 155 #if (DA_CORE == 1)
 156              FILE   = "namelist.output.da" ,      &
 157 #else
 158              FILE   = "namelist.output" ,      &
 159 #endif
 160              FORM   = "FORMATTED"      ,      &
 161              STATUS = "REPLACE"        ,      &
 162              IOSTAT = io_status         )
 163
 164       IF ( io_status .NE. 0 ) THEN
 165 #if (DA_CORE == 1)
 166         CALL WRF_ERROR_FATAL ( 'ERROR OPENING namelist.output.da' )
 167 #else
 168         CALL WRF_ERROR_FATAL ( 'ERROR OPENING namelist.output' )
 169 #endif
 170       ENDIF
 171 #endif
 172
 173 ! Statements that set the namelist vars to default vals
 174 #  include "namelist_defaults.inc"
 175
 176 #if (DA_CORE == 1)
 177 ! Override the default values, because we can not assigned a arrary with different values in registry.
 178
 179       as1(1:3) = (/ 0.25, 1.0, 1.5 /)
 180       as2(1:3) = (/ 0.25, 1.0, 1.5 /)
 181       as3(1:3) = (/ 0.25, 1.0, 1.5 /)
 182       as4(1:3) = (/ 0.25, 1.0, 1.5 /)
 183       as5(1:3) = (/ 0.25, 1.0, 1.5 /)
 184 #endif
 185
 186 ! Statements that read the namelist are in this file
 187 #  include "config_reads.inc"
 188
 189 ! 2004/04/28  JM (with consensus by the group of developers)
 190 ! This is needed to ensure that nesting will work, since
 191 ! different mp_physics packages have different numbers of
 192 ! tracers. Basically, this says that the microphysics option
 193 ! specified on the highest numbered domain *is* the microphysics
 194 ! option for the run. Not the best solution but okay for 2.0.
 195 !
 196
 197       DO i = 1, max_dom
 198          mp_physics(i) = mp_physics(max_dom)
 199       ENDDO
 200
 201 ! Statements that assign the variables to the cfg record are in this file
 202 ! except the namelist_derived variables where are assigned below
 203 #undef SOURCE_RECORD
 204 #undef DEST_RECORD
 205 #undef SOURCE_REC_DEX
 206 #define SOURCE_RECORD
 207 #define DEST_RECORD model_config_rec %
 208 #define SOURCE_REC_DEX
 209 #include "config_assigns.inc"
 210
 211
 212       CLOSE ( UNIT = nml_read_unit , IOSTAT = io_status )
 213
 214       IF ( io_status .NE. 0 ) THEN
 215         CALL WRF_ERROR_FATAL ( 'ERROR CLOSING namelist.input' )
 216       ENDIF
 217
 218 #ifndef NO_NAMELIST_PRINT
 219       CLOSE ( UNIT = nml_write_unit , IOSTAT = io_status )
 220
 221       IF ( io_status .NE. 0 ) THEN
 222         CALL WRF_ERROR_FATAL ( 'ERROR CLOSING namelist.output' )
 223       ENDIF
 224 #endif
 225
 226 #ifdef _WIN32
 227       model_config_rec%nocolons = .TRUE.   ! always no colons for Windows
 228 #endif
 229
 230       RETURN
 231
 232    END SUBROUTINE initial_config
 233
 234 #if 1
 235    SUBROUTINE get_config_as_buffer( buffer, buflen, ncopied )
 236 ! note that model_config_rec_type must be defined as a sequence derived type
 237       INTEGER,   INTENT(INOUT) ::  buffer(*)
 238       INTEGER,   INTENT(IN)    ::  buflen
 239       INTEGER,   INTENT(OUT)   ::  ncopied
 240 !      TYPE(model_config_rec_type) :: model_config_rec
 241       INTEGER :: nbytes
 242       CALL wrf_num_bytes_between ( model_config_rec%last_item_in_struct ,   &
 243                                    model_config_rec%first_item_in_struct ,  &
 244                                    nbytes )
 245 !      nbytes = loc(model_config_rec%last_item_in_struct) - &
 246 !               loc(model_config_rec%first_item_in_struct)
 247       IF ( nbytes .gt. buflen ) THEN
 248         CALL wrf_error_fatal( &
 249         "get_config_rec_as_buffer: buffer size too small for config_rec" )
 250       ENDIF
 251       CALL wrf_mem_copy( model_config_rec, buffer, nbytes )
 252       ncopied = nbytes
 253       RETURN
 254    END SUBROUTINE get_config_as_buffer
 255
 256    SUBROUTINE set_config_as_buffer( buffer, buflen )
 257 ! note that model_config_rec_type must be defined as a sequence derived type
 258       INTEGER,   INTENT(INOUT) ::  buffer(*)
 259       INTEGER,   INTENT(IN)    ::  buflen
 260 !      TYPE(model_config_rec_type) :: model_config_rec
 261       INTEGER :: nbytes
 262       CALL wrf_num_bytes_between ( model_config_rec%last_item_in_struct ,  &
 263                                    model_config_rec%first_item_in_struct , &
 264                                    nbytes )
 265 !      nbytes = loc(model_config_rec%last_item_in_struct) - &
 266 !               loc(model_config_rec%first_item_in_struct)
 267       IF ( nbytes .gt. buflen ) THEN
 268         CALL wrf_error_fatal( &
 269         "set_config_rec_as_buffer: buffer length too small to fill model config record" )
 270       ENDIF
 271       CALL wrf_mem_copy( buffer, model_config_rec, nbytes )
 272       RETURN
 273    END SUBROUTINE set_config_as_buffer
 274 #else
 275    SUBROUTINE get_config_as_buffer( buffer, buflen, ncopied )
 276 ! note that model_config_rec_type must be defined as a sequence derived type
 277       INTEGER*1, INTENT(INOUT) ::  buffer(*)
 278       INTEGER,   INTENT(IN)    ::  buflen
 279       INTEGER,   INTENT(OUT)   ::  ncopied
 280 !      TYPE(model_config_rec_type) :: model_config_rec
 281       INTEGER :: nbytes
 282       nbytes = loc(model_config_rec%last_item_in_struct) - &
 283                loc(model_config_rec%first_item_in_struct)
 284       IF ( nbytes .gt. buflen ) THEN
 285         CALL wrf_error_fatal( &
 286         "get_config_rec_as_buffer: buffer size too small for config_rec" )
 287       ENDIF
 288       CALL wrf_mem_copy( model_config_rec, buffer, nbytes )
 289       ncopied = nbytes
 290       RETURN
 291    END SUBROUTINE get_config_as_buffer
 292
 293    SUBROUTINE set_config_as_buffer( buffer, buflen )
 294 ! note that model_config_rec_type must be defined as a sequence derived type
 295       INTEGER*1, INTENT(INOUT) ::  buffer(*)
 296       INTEGER,   INTENT(IN)    ::  buflen
 297 !      TYPE(model_config_rec_type) :: model_config_rec
 298       INTEGER :: nbytes
 299       nbytes = loc(model_config_rec%last_item_in_struct) - &
 300                loc(model_config_rec%first_item_in_struct)
 301       IF ( nbytes .gt. buflen ) THEN
 302         CALL wrf_error_fatal( &
 303         "set_config_rec_as_buffer: buffer length too small to fill model config record" )
 304       ENDIF
 305       CALL wrf_mem_copy( buffer, model_config_rec, nbytes )
 306       RETURN
 307    END SUBROUTINE set_config_as_buffer
 308 #endif
 309
 310    SUBROUTINE model_to_grid_config_rec ( id_id , model_config_rec , grid_config_rec )
 311       INTEGER , INTENT(IN)                         ::  id_id
 312       TYPE ( model_config_rec_type ) , INTENT(IN)  ::  model_config_rec
 313       TYPE ( grid_config_rec_type  ) , INTENT(OUT) ::  grid_config_rec
 314 ! <DESCRIPTION>
 315 ! This routine is called to populate a domain specific configuration
 316 ! record of TYPE(grid_config_rec_type) with the configuration information
 317 ! for that domain that is stored in TYPE(model_config_rec). Both types
 318 ! are defined in frame/module_configure.F.  The input argument is the
 319 ! record of type model_config_rec_type contains the model-wide
 320 ! configuration information (that is, settings that apply to the model in
 321 ! general) and configuration information for each individual domain.  The
 322 ! output argument is the record of type grid_config_rec_type which
 323 ! contains the model-wide configuration information and the
 324 ! domain-specific information for this domain only.  In the
 325 ! model_config_rec, the domain specific information is arrays, indexed by
 326 ! the grid id's.  In the grid_config_rec the domain-specific information
 327 ! is scalar and for the specific domain.  The first argument to this
 328 ! routine is the grid id (top-most domain is always 1) as specified in
 329 ! the domain-specific namelist variable grid_id.
 330 !
 331 ! The actual assignments form the model_config_rec_type to the
 332 ! grid_config_rec_type are generate from the rconfig entries in the
 333 ! Registry file and included by this routine from the file
 334 ! inc/config_assigns.inc.
 335 !
 336 !NOTE: generated subroutines from Registry file rconfig entries are renamed nl_
 337 ! instead of rconfig_ due to length limits for subroutine names.
 338 !
 339 !
 340 ! </DESCRIPTION>
 341 #undef SOURCE_RECORD
 342 #undef SOURCE_REC_DEX
 343 #undef DEST_RECORD
 344 #define SOURCE_RECORD model_config_rec %
 345 #define SOURCE_REC_DEX (id_id)
 346 #define DEST_RECORD   grid_config_rec %
 347 #include "config_assigns.inc"
 348    END SUBROUTINE model_to_grid_config_rec
 349
 350
 351    FUNCTION in_use_for_config ( id, vname ) RESULT ( in_use )
 352      INTEGER, INTENT(IN) :: id
 353      CHARACTER*(*), INTENT(IN) :: vname
 354      LOGICAL in_use
 355      INTEGER uses
 356
 357      uses = 0
 358      in_use = .TRUE.
 359
 360      IF      ( vname(1:1) .EQ. 'a' ) THEN
 361 #    include "in_use_for_config_a.inc"
 362      ELSE IF ( vname(1:1) .EQ. 'b' ) THEN
 363 #    include "in_use_for_config_b.inc"
 364      ELSE IF ( vname(1:1) .EQ. 'c' ) THEN
 365 #    include "in_use_for_config_c.inc"
 366      ELSE IF ( vname(1:1) .EQ. 'd' ) THEN
 367 #    include "in_use_for_config_d.inc"
 368      ELSE IF ( vname(1:1) .EQ. 'e' ) THEN
 369 #    include "in_use_for_config_e.inc"
 370      ELSE IF ( vname(1:1) .EQ. 'f' ) THEN
 371 #    include "in_use_for_config_f.inc"
 372      ELSE IF ( vname(1:1) .EQ. 'g' ) THEN
 373 #    include "in_use_for_config_g.inc"
 374      ELSE IF ( vname(1:1) .EQ. 'h' ) THEN
 375 #    include "in_use_for_config_h.inc"
 376      ELSE IF ( vname(1:1) .EQ. 'i' ) THEN
 377 #    include "in_use_for_config_i.inc"
 378      ELSE IF ( vname(1:1) .EQ. 'j' ) THEN
 379 #    include "in_use_for_config_j.inc"
 380      ELSE IF ( vname(1:1) .EQ. 'k' ) THEN
 381 #    include "in_use_for_config_k.inc"
 382      ELSE IF ( vname(1:1) .EQ. 'l' ) THEN
 383 #    include "in_use_for_config_l.inc"
 384      ELSE IF ( vname(1:1) .EQ. 'm' ) THEN
 385 #    include "in_use_for_config_m.inc"
 386      ELSE IF ( vname(1:1) .EQ. 'n' ) THEN
 387 #    include "in_use_for_config_n.inc"
 388      ELSE IF ( vname(1:1) .EQ. 'o' ) THEN
 389 #    include "in_use_for_config_o.inc"
 390      ELSE IF ( vname(1:1) .EQ. 'p' ) THEN
 391 #    include "in_use_for_config_p.inc"
 392      ELSE IF ( vname(1:1) .EQ. 'q' ) THEN
 393 #    include "in_use_for_config_q.inc"
 394      ELSE IF ( vname(1:1) .EQ. 'r' ) THEN
 395 #    include "in_use_for_config_r.inc"
 396      ELSE IF ( vname(1:1) .EQ. 's' ) THEN
 397 #    include "in_use_for_config_s.inc"
 398      ELSE IF ( vname(1:1) .EQ. 't' ) THEN
 399 #    include "in_use_for_config_t.inc"
 400      ELSE IF ( vname(1:1) .EQ. 'u' ) THEN
 401 #    include "in_use_for_config_u.inc"
 402      ELSE IF ( vname(1:1) .EQ. 'v' ) THEN
 403 #    include "in_use_for_config_v.inc"
 404      ELSE IF ( vname(1:1) .EQ. 'w' ) THEN
 405 #    include "in_use_for_config_w.inc"
 406      ELSE IF ( vname(1:1) .EQ. 'x' ) THEN
 407 #    include "in_use_for_config_x.inc"
 408      ELSE IF ( vname(1:1) .EQ. 'y' ) THEN
 409 #    include "in_use_for_config_y.inc"
 410      ELSE IF ( vname(1:1) .EQ. 'z' ) THEN
 411 #    include "in_use_for_config_z.inc"
 412      ENDIF
 413
 414      RETURN
 415    END FUNCTION
 416
 417
 418 ! Include the definitions of all the routines that return a namelist values
 419 ! back to the driver. These are generated by the registry
 420
 421    SUBROUTINE init_module_configure
 422      USE module_scalar_tables
 423      IMPLICIT NONE
 424      CALL init_module_scalar_tables
 425    END SUBROUTINE init_module_configure
 426
 427    SUBROUTINE wrf_alt_nml_obsolete (nml_read_unit, nml_name)
 428 !
 429 !<DESCRIPTION>
 430 ! If there is an error reading the "nml_name" namelist, this routine is
 431 ! called to check for namelist variables that have been removed by the
 432 ! developers and are still in user's namelists.
 433 !
 434 ! The calls to this routine are in registry-generated code: inc/config_reads.inc
 435 !</DESCRIPTION>
 436 !
 437      IMPLICIT NONE
 438      INTEGER, INTENT(IN)       :: nml_read_unit
 439      CHARACTER*(*), INTENT(IN) :: nml_name
 440      INTEGER                   :: nml_error
 441
 442 #include "namelist_defines.inc"
 443 #include "namelist_statements.inc"
 444
 445 ! These are the variables that have been removed
 446      logical , DIMENSION(max_domains) :: pd_moist, pd_chem, pd_tke, pd_scalar
 447      NAMELIST /dynamics/                 pd_moist, pd_chem, pd_tke, pd_scalar
 448
 449      integer , DIMENSION(max_domains) :: ucmcall
 450      NAMELIST /physics/                  ucmcall
 451
 452      integer , DIMENSION(max_domains) :: obs_nobs_prt
 453      NAMELIST /fdda/                     obs_nobs_prt
 454
 455      LOGICAL ::         global, print_detail_airep, print_detail_timing
 456      NAMELIST /wrfvar1/ global, print_detail_airep, print_detail_timing
 457
 458      LOGICAL ::         write_qcw, write_qrn, write_qci, write_qsn
 459      NAMELIST /wrfvar2/ write_qcw, write_qrn, write_qci, write_qsn
 460      LOGICAL ::          write_qgr, write_filtered_obs
 461      NAMELIST /wrfvar2/  write_qgr, write_filtered_obs
 462
 463      LOGICAL ::         use_eos_radobs, use_3dvar_phy
 464      NAMELIST /wrfvar4/ use_eos_radobs, use_3dvar_phy
 465
 466      LOGICAL             :: use_crtm_kmatrix_fast
 467      NAMELIST /wrfvar14/    use_crtm_kmatrix_fast
 468      CHARACTER (LEN=256) :: spccoeff_file, taucoeff_file, aerosolcoeff_file
 469      NAMELIST /wrfvar14/    spccoeff_file, taucoeff_file, aerosolcoeff_file
 470      CHARACTER (LEN=256) :: cloudcoeff_file, emiscoeff_file
 471      NAMELIST /wrfvar14/    cloudcoeff_file, emiscoeff_file
 472
 473      LOGICAL             :: alpha_vertloc
 474      NAMELIST /wrfvar16/    alpha_vertloc
 475
 476
 477 ! Read the namelist again, if it succeeds after adding the above variables,
 478 ! it probably failed because these are still in the namelist.  If it fails
 479 ! again, we will return.
 480
 481      REWIND ( UNIT = nml_read_unit )
 482
 483 !----------------------------- dynamics ---------------------------------
 484      if ( TRIM(nml_name) .eq. "dynamics" ) then
 485
 486         READ   ( UNIT = nml_read_unit , NML = dynamics , iostat=nml_error )
 487
 488         IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
 489            CALL wrf_debug(0, "-- Are pd_moist, pd_chem, pd_tke, or pd_scalar still in your "// &
 490                                TRIM(nml_name)//" namelist?")
 491            CALL wrf_debug(0, "-- Replace them with moist_adv_opt, chem_adv_opt, tke_adv_opt "// &
 492                              " and scalar_adv_opt, respectively.")
 493         ENDIF
 494
 495 !---------------------------------- physics -----------------------------
 496      else if ( TRIM(nml_name) .eq. "physics" ) then
 497
 498         READ   ( UNIT = nml_read_unit , NML = physics , iostat=nml_error )
 499
 500         IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
 501            CALL wrf_debug(0, "-- Is ucmcall still in your "// TRIM(nml_name)//" namelist?")
 502            CALL wrf_debug(0, "-- Replace it with sf_urban_physics")
 503         ENDIF
 504
 505 !---------------------------------- fdda --------------------------------
 506      else if ( TRIM(nml_name) .eq. "fdda" ) then
 507
 508         READ   ( UNIT = nml_read_unit , NML = fdda , iostat=nml_error )
 509
 510         IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
 511            CALL wrf_debug(0, "-- Is obs_nobs_prt still in your "// TRIM(nml_name)//" namelist?")
 512            CALL wrf_debug(0, "-- Replace it with obs_prt_max")
 513         ENDIF
 514
 515 !---------------------------------- wrfvar1 -----------------------------
 516      else if ( TRIM(nml_name) .eq. "wrfvar1" ) then
 517
 518         READ   ( UNIT = nml_read_unit , NML = wrfvar1 , iostat=nml_error )
 519
 520         IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
 521            CALL wrf_debug(0, "-- Are global, print_detail_airep, print_detail_timing still in your "// &
 522                               TRIM(nml_name)//" namelist?")
 523            CALL wrf_debug(0, "-- Remove global, print_detail_airep, print_detail_timing "// &
 524                              "from wrfvar1 namelist as they are obsolete.")
 525         ENDIF
 526
 527 !---------------------------------- wrfvar2 -----------------------------
 528      else if ( TRIM(nml_name) .eq. "wrfvar2" ) then
 529
 530         READ   ( UNIT = nml_read_unit , NML = wrfvar2 , iostat=nml_error )
 531
 532         IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
 533            CALL wrf_debug(0, "-- Are write_qcw, write_qrn, write_qci, write_qsn, write_qgr, "// &
 534                              "write_filtered_obs still in your "// &
 535                               TRIM(nml_name)//" namelist?")
 536            CALL wrf_debug(0, "-- Remove write_qcw, write_qrn, write_qci, write_qsn, write_qgr, "// &
 537                              "write_filtered_obs as they are obsolete.")
 538         ENDIF
 539
 540 !---------------------------------- wrfvar4 -----------------------------
 541      else if ( TRIM(nml_name) .eq. "wrfvar4" ) then
 542
 543         READ   ( UNIT = nml_read_unit , NML = wrfvar4 , iostat=nml_error )
 544
 545         IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
 546            CALL wrf_debug(0, "-- Is use_3dvar_phy or use_eos_radobs still in your "// &
 547                               TRIM(nml_name)//" namelist?")
 548            CALL wrf_debug(0, "-- Remove use_3dvar_phy, use_eos_radobs as they are obsolete.")
 549         ENDIF
 550
 551 !---------------------------------- wrfvar14 -----------------------------
 552      else if ( TRIM(nml_name) .eq. "wrfvar14" ) then
 553
 554      READ   ( UNIT = nml_read_unit , NML = wrfvar14 , iostat=nml_error )
 555
 556         IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
 557            CALL wrf_debug(0, "-- Are use_crtm_kmatrix_fast, spccoeff_file, taucoeff_file, "// &
 558                              "aerosolcoeff_file, cloudcoeff_file, emiscoeff_file still in your "// &
 559                               TRIM(nml_name)//" namelist?")
 560            CALL wrf_debug(0, "-- Remove them as they are obsolete.")
 561         ENDIF
 562
 563 !---------------------------------- wrfvar16 -----------------------------
 564      else if ( TRIM(nml_name) .eq. "wrfvar16" ) then
 565
 566      READ   ( UNIT = nml_read_unit , NML = wrfvar16 , iostat=nml_error )
 567
 568         IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
 569            CALL wrf_debug(0, "-- Is alpha_vertloc still in your "// &
 570                               TRIM(nml_name)//" namelist?")
 571            CALL wrf_debug(0, "-- Remove it as it is obsolete.")
 572            CALL wrf_debug(0, "-- For EnVar DA (ensdim_alpha>0), set proper alpha_vertloc_opt instead.")
 573         ENDIF
 574
 575 !---------------------------------- error -------------------------------
 576      else
 577          IF ( &
 578 #include "namelist_nametest.inc"
 579               ) THEN
 580             nml_error = 0
 581          ELSE
 582             CALL wrf_debug(0, TRIM(nml_name)//" is not a valid namelist name")
 583          ENDIF
 584      end if
 585
 586      IF ( nml_error .NE. 0 ) then    ! Still failed
 587         return
 588      ENDIF
 589
 590    END SUBROUTINE wrf_alt_nml_obsolete
 591
 592 END MODULE module_configure
 593
 594 #if( WRF_CHEM == 1 && WRF_KPP == 1 )
 595 INTEGER FUNCTION get_funit()
 596
 597     IMPLICIT NONE
 598
 599     INTEGER, PARAMETER :: min_unit_number = 30
 600     INTEGER, PARAMETER :: max_unit_number = 99
 601
 602     LOGICAL :: opened
 603
 604     DO get_funit = min_unit_number, max_unit_number
 605        INQUIRE(UNIT=get_funit, OPENED=opened)
 606        IF ( .NOT. opened ) RETURN
 607     END DO
 608
 609     get_funit = -1
 610
 611 END FUNCTION get_funit
 612 #endif
 613
 614 SUBROUTINE set_scalar_indices_from_config ( idomain , dummy2, dummy1 )
 615   USE module_driver_constants
 616   USE module_state_description
 617   USE module_wrf_error
 618   USE module_configure, ONLY : model_config_rec
 619   USE module_scalar_tables
 620 #if( WRF_CHEM == 1 && WRF_KPP == 1 )
 621   USE module_irr_diag
 622 #endif
 623   IMPLICIT NONE
 624   INTEGER , INTENT(IN)  :: idomain
 625   INTEGER               :: dummy1
 626   INTEGER               :: dummy2
 627
 628 #if( WRF_CHEM == 1 && WRF_KPP == 1 )
 629   INTEGER :: astat, istat
 630   INTEGER :: l, m, n
 631   INTEGER :: ndx
 632   INTEGER :: irr_cnt
 633   INTEGER :: nFound
 634   INTEGER :: funit
 635   INTEGER :: chem_opt
 636   INTEGER, ALLOCATABLE :: irr_ndx(:)
 637   CHARACTER(LEN=128) :: err_mes
 638   CHARACTER(LEN=128) :: fname
 639   CHARACTER(LEN=64)  :: irr_rxt, lc_tmp
 640   CHARACTER(LEN=64), POINTER     :: rxt_lst(:)
 641   CHARACTER(LEN=32), ALLOCATABLE :: irr_lst(:)
 642   LOGICAL, ALLOCATABLE :: irr_msk(:)
 643   LOGICAL :: found, opened
 644   LOGICAL :: do_all
 645
 646   INTEGER :: get_funit
 647
 648 #include "scalar_indices_irr_diag_decls.inc"
 649 #endif
 650
 651 !<DESCRIPTION>
 652 !This routine is called to adjust the integer variables that are defined
 653 !in frame/module_state_description.F (Registry-generated) and that serve
 654 !as indices into 4D tracer arrays for moisture, chemistry, etc.
 655 !Different domains (different grid data structures) are allowed to have
 656 !different sets of tracers so these indices can vary from domain to
 657 !domain. However, since the indices are defined globally in
 658 !module_state_description (a shortcoming in the current software), it is
 659 !necessary that these indices be reset each time a different grid is to
 660 !be computed on.
 661 !
 662 !The scalar idices are set according to the particular physics
 663 !packages -- more specifically in the case of the moisture tracers, microphysics
 664 !packages -- that are stored for each domain in model_config_rec and
 665 !indexed by the grid id, passed in as an argument to this routine.  (The
 666 !initial_config() routine in module_configure is what reads the
 667 !namelist.input file and sets model_config_rec.)
 668 !
 669 !The actual code for calculating the scalar indices on a particular
 670 !domain is generated from the Registry state array definitions for the
 671 !4d tracers and from the package definitions that indicate which physics
 672 !packages use which tracers.
 673 !
 674 !</DESCRIPTION>
 675
 676 #include "scalar_indices.inc"
 677 #if( WRF_CHEM == 1 && WRF_KPP == 1 )
 678 #include "scalar_indices_irr_diag.inc"
 679
 680    CALL init_module_irr_diag
 681
 682 has_irr_diag: &
 683    IF( model_config_rec%irr_opt(idomain) == 1 .and. .not. irr_active(idomain) ) THEN
 684      do_all = .false.
 685      irr_active(idomain) = .true.
 686      CALL nl_get_chem_opt( idomain, chem_opt )
 687      DO chm_opt_ndx = 1,nchm_opts
 688        IF( chem_opt == chm_opts_ndx(chm_opt_ndx) ) THEN
 689          EXIT
 690        ENDIF
 691      ENDDO
 692      IF( chm_opt_ndx > nchm_opts ) THEN
 693        write(err_mes,'(''IRR not supported for chem option '',i3.3)') chem_opt
 694        CALL wrf_error_fatal( trim(err_mes) )
 695      ENDIF
 696      funit = get_funit()
 697      write(fname,'(''wrfchem_irr_diag_d'',i2.2)') idomain
 698      OPEN( unit = funit, file=trim(fname), status='OLD', iostat=istat )
 699      IF( istat /= 0 ) THEN
 700        write(err_mes,'(''IRR failed to open '',a)') trim(fname)
 701        CALL wrf_error_fatal( trim(err_mes) )
 702      ENDIF
 703      irr_cnt = 0
 704      DO
 705        read(funit,'(a)',iostat=istat) irr_rxt
 706        IF( istat /= 0 ) THEN
 707          EXIT
 708        ENDIF
 709        irr_cnt = irr_cnt + 1
 710        if( irr_cnt == 1 ) then
 711          CALL change_to_lower_case( irr_rxt, lc_tmp )
 712          if( trim(lc_tmp) == 'all' ) then
 713            do_all  = .true.
 714            irr_cnt = chm_opts_cnt(chm_opt_ndx)
 715            write(err_mes,'(''IRR do_all, irr_cnt = '',l,i4)') do_all, irr_cnt
 716            CALL wrf_debug( 0,trim(err_mes) )
 717            EXIT
 718          endif
 719        endif
 720      ENDDO
 721
 722 has_irr_input: &
 723      IF( irr_cnt == 0 ) THEN
 724        CALL nl_set_irr_opt( idomain, 0 )
 725      ELSE has_irr_input
 726        ALLOCATE( irr_lst(irr_cnt),irr_msk(irr_cnt),irr_ndx(irr_cnt),stat=astat )
 727        IF( astat /= 0 ) THEN
 728          write(err_mes,'(''IRR failed to allocate irr_lst .. irr_ndx; error = '',i8)') astat
 729          CALL wrf_error_fatal( trim(err_mes) )
 730        ENDIF
 731        if( .not. do_all ) THEN
 732          REWIND( funit )
 733        ENDIF
 734        nFound = 0
 735        irr_msk(:) = .false.
 736        irr_ndx(:) = 0
 737        rxt_lst => rxtsym(:,chm_opt_ndx)
 738 input_irr_loop: &
 739        DO n = 1,irr_cnt
 740          IF( .not. do_all ) THEN
 741            read(funit,'(a)',iostat=istat) irr_lst(n)
 742            IF( istat /= 0 ) THEN
 743              write(err_mes,'(''IRR failed to read '',a)') trim(fname)
 744              CALL wrf_error_fatal( trim(err_mes) )
 745            ENDIF
 746            found = .false.
 747          ELSE
 748            irr_lst(n) = rxt_lst(n)
 749            found = .false.
 750          ENDIF
 751 rxt_loop: &
 752          DO l = 1,chm_opts_cnt(chm_opt_ndx)
 753 have_match: &
 754            IF( trim(rxt_lst(l)) == trim(irr_lst(n)) ) THEN
 755              found = .true.
 756              nFound = nFound + 1
 757              irr_ndx(nFound) = l
 758              irr_msk(nFound) = .true.
 759              irr_rxt = rxt_lst(l)
 760              do m = 1,len_trim( irr_rxt )
 761                if( irr_rxt(m:m) == '+' ) then
 762                  irr_rxt(m:m) = '_'
 763                endif
 764              enddo
 765              SELECT CASE( chm_opts_ndx(chm_opt_ndx) )
 766                CASE( MOZCART_KPP )
 767                  irr_diag_mozcart_num_table(idomain) = irr_diag_mozcart_num_table(idomain) + 1
 768                  ndx = irr_diag_mozcart_num_table(idomain)
 769                  irr_diag_mozcart_boundary_table(idomain,ndx) = .FALSE.
 770                  irr_diag_mozcart_dname_table(idomain,ndx) = trim( irr_rxt ) // '_IRR'
 771                  irr_diag_mozcart_desc_table(idomain,ndx)  = trim(rxt_lst(l) ) // ' Integrated Reaction Rate'
 772                  irr_diag_mozcart_units_table(idomain,ndx) = 'ppmv'
 773                  irr_diag_mozcart_streams_table(idomain,ndx)%stream(1) = 512
 774                  irr_diag_mozcart_streams_table(idomain,ndx)%stream(2) = 2097152
 775                CASE( T1_MOZCART_KPP )
 776                  irr_diag_t1_mozcart_num_table(idomain) = irr_diag_t1_mozcart_num_table(idomain) + 1
 777                  ndx = irr_diag_t1_mozcart_num_table(idomain)
 778                  irr_diag_t1_mozcart_boundary_table(idomain,ndx) = .FALSE.
 779                  irr_diag_t1_mozcart_dname_table(idomain,ndx) = trim( irr_rxt ) // '_IRR'
 780                  irr_diag_t1_mozcart_desc_table(idomain,ndx)  = trim(rxt_lst(l) ) // ' Integrated Reaction Rate'
 781                  irr_diag_t1_mozcart_units_table(idomain,ndx) = 'ppmv'
 782                  irr_diag_t1_mozcart_streams_table(idomain,ndx)%stream(1) = 512
 783                  irr_diag_t1_mozcart_streams_table(idomain,ndx)%stream(2) = 2097152
 784                CASE( MOZART_MOSAIC_4BIN_KPP )
 785                  irr_diag_mozart_mosaic_4bin_num_table(idomain) = irr_diag_mozart_mosaic_4bin_num_table(idomain) + 1
 786                  ndx = irr_diag_mozart_mosaic_4bin_num_table(idomain)
 787                  irr_diag_mozart_mosaic_4bin_boundary_table(idomain,ndx) = .FALSE.
 788                  irr_diag_mozart_mosaic_4bin_dname_table(idomain,ndx) = trim( irr_rxt ) // '_IRR'
 789                  irr_diag_mozart_mosaic_4bin_desc_table(idomain,ndx)  = trim(rxt_lst(l) ) // ' Integrated Reaction Rate'
 790                  irr_diag_mozart_mosaic_4bin_units_table(idomain,ndx) = 'ppmv'
 791                  irr_diag_mozart_mosaic_4bin_streams_table(idomain,ndx)%stream(1) = 512
 792                  irr_diag_mozart_mosaic_4bin_streams_table(idomain,ndx)%stream(2) = 2097152
 793                CASE( MOZART_MOSAIC_4BIN_AQ_KPP )
 794                  irr_diag_mozart_mosaic_4bin_aq_num_table(idomain) = irr_diag_mozart_mosaic_4bin_aq_num_table(idomain) + 1
 795                  ndx = irr_diag_mozart_mosaic_4bin_aq_num_table(idomain)
 796                  irr_diag_mozart_mosaic_4bin_aq_boundary_table(idomain,ndx) = .FALSE.
 797                  irr_diag_mozart_mosaic_4bin_aq_dname_table(idomain,ndx) = trim( irr_rxt ) // '_IRR'
 798                  irr_diag_mozart_mosaic_4bin_aq_desc_table(idomain,ndx)  = trim( rxt_lst(l) ) // ' Integrated Reaction Rate'
 799                  irr_diag_mozart_mosaic_4bin_aq_units_table(idomain,ndx) = 'ppmv'
 800                  irr_diag_mozart_mosaic_4bin_aq_streams_table(idomain,ndx)%stream(1) = 512
 801                  irr_diag_mozart_mosaic_4bin_aq_streams_table(idomain,ndx)%stream(2) = 2097152
 802              END SELECT
 803              EXIT rxt_loop
 804            ENDIF have_match
 805          ENDDO rxt_loop
 806        ENDDO input_irr_loop
 807        IF( nFound > 0 ) THEN
 808          irr_option(idomain) = .true.
 809          irr_diag_ndx(:nFound,idomain) = irr_ndx(:nFound)
 810          irr_diag_cnt(idomain) = nFound
 811        ENDIF
 812      ENDIF has_irr_input
 813
 814      INQUIRE( unit=funit,opened=opened )
 815      IF( opened ) THEN
 816        CLOSE( funit )
 817      ENDIF
 818
 819      IF( ALLOCATED( irr_lst ) ) THEN
 820        DEALLOCATE( irr_lst )
 821      ENDIF
 822      IF( ALLOCATED( irr_msk ) ) THEN
 823        DEALLOCATE( irr_msk )
 824      ENDIF
 825      IF( ALLOCATED( irr_ndx ) ) THEN
 826        DEALLOCATE( irr_ndx )
 827      ENDIF
 828    ENDIF has_irr_diag
 829
 830
 831 #endif
 832 #include "scalar_indices_init.inc"
 833   RETURN
 834 END SUBROUTINE set_scalar_indices_from_config
 835
 836 #if ( DA_CORE != 1 )
 837    SUBROUTINE change_to_lower_case(instr,outstr)
 838      CHARACTER*(*) ,INTENT(IN)  :: instr
 839      CHARACTER*(*) ,INTENT(OUT) :: outstr
 840 !Local
 841      CHARACTER*1                :: c
 842      INTEGER       ,PARAMETER   :: upper_to_lower =IACHAR('a')-IACHAR('A')
 843      INTEGER                    :: i,n,n1
 844 !
 845      outstr = ' '
 846      N  = len(instr)
 847      N1 = len(outstr)
 848      N  = MIN(N,N1)
 849      outstr(1:N) = instr(1:N)
 850      DO i=1,N
 851        c = instr(i:i)
 852        if('A'<=c .and. c <='Z') outstr(i:i)=achar(iachar(c)+upper_to_lower)
 853      ENDDO
 854
 855    END SUBROUTINE change_to_lower_case
 856 #endif