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