!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE READNAMELIST ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE readnamelist(progopt,max_dom,input_from_file, & 2,65
hinfmt,adasbasfn,adashisfn,bdybasfn,hisfile,nhisfile,finexist, &
nx,ny,nz,nzsoil,nstyps,nprocx_in,nprocy_in,ncompressx,ncompressy, &
use_arps_grid,nx_wrf,ny_wrf,nz_wrf,zlevels_wrf,ptop, &
i_parent_start,j_parent_start,parent_id, &
mapproj_wrf,sclfct_wrf,lattru_wrf,lontru_wrf, &
ctrlat_wrf,ctrlon_wrf,dx_wrf,dy_wrf,dt, &
base_pres,base_temp,base_lapse, &
sfcinitopt,wrftrnopt,sfcdtfn,geogdir,start_date,silwt,wvln, &
create_bdy,mgrdbas,tintv_bdywrf,tintv_bdyin,spec_bdy_width, &
diff_opt,km_opt,khdif,kvdif,mp_physics,ra_lw_physics, &
ra_sw_physics,sf_sfclay_physics,sf_surface_physics,bl_pbl_physics, &
cu_physics, nprocx_wrf,nprocy_wrf,frames_per_outfile, &
restart_interval,radt,cudt,ifsnow,w_damping,parent_time_step_ratio,&
iorder,korder,io_form,qx_zero_out,create_namelist,wrfnamelist, &
io_form_history, io_form_restart, history_interval, &
indir,outdir,staticdir,pd_moist, &
istatus)
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! To read and propagate namelist input.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Yunheng Wang
! 09/15/2005
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER, INTENT(IN) :: progopt ! 0 = ARPS2WRF
! 1 = WRFSTATIC
INTEGER, INTENT(OUT) :: istatus
!----------------------------------------------------------------------
!
! ARPS grid variables
!
!---------------------------------------------------------------------
INTEGER, PARAMETER :: nmax_domains = 100
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: nx,ny,nz ! Grid dimensions for ARPS.
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: nzsoil ! Soil levels
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: nstyps ! Maximum number of soil types.
INTEGER, PARAMETER :: nhisfile_max = 100
INTEGER, PARAMETER :: max_vertical_levels = 100
CHARACTER(LEN=*), INTENT(OUT) :: hisfile(nhisfile_max)
CHARACTER(LEN=*), INTENT(OUT) :: bdybasfn(nhisfile_max)
INTEGER, INTENT(OUT) :: nhisfile
CHARACTER(LEN=256) :: grdbasfn
INTEGER :: lengbf
! hisfile(1) and bdybasfn(1) are for WRF input file
! They can be any ARPS history dumps including ADAS output,
! ARPS output or EXT2ARPS output
!
! hisfile(2:nhisfil), bdybasfn(2:nhisfile) are for
! WRF lateral bounday files. They can be either ARPS history
! dumps or EXT2ARPS outputs
CHARACTER(LEN=4), PARAMETER :: finfmt(11) = &
(/'.bin','.asc','.hdf','.pak','.svi','.bn2', &
'.net','.npk','.gad','.grb','.v5d' /)
INTEGER, INTENT(OUT) :: finexist(nhisfile_max)
!
!-----------------------------------------------------------------------
!
! ARPS include files:
!
!-----------------------------------------------------------------------
!
INCLUDE 'globcst.inc'
INCLUDE 'mp.inc'
!
!-----------------------------------------------------------------------
!
! Variables for mpi jobs
!
!-----------------------------------------------------------------------
INTEGER, PARAMETER :: fzone_arps = 3, fzone_wrf = 1
INTEGER, INTENT(OUT) :: ncompressx, ncompressy ! compression in x and y direction:
! ncompressx=nprocx_in/nproc_x
! ncompressy=nprocy_in/nproc_y
INTEGER, INTENT(OUT) :: nprocx_in, nprocy_in
!-----------------------------------------------------------------------
!
! Namelist definitions for ARPS2WRF.input
!
! sfcdt Specify surface characteristics
! bdyspc Obtain boundary input files (ARPS format)
! wrf_grid Define WRF horizontal and vertical grid
! interp_options Choose interpolation scheme
! wrf_opts WRF options from namelist.input
! output Ouput options
!
!-----------------------------------------------------------------------
!
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: nx_wrf ! = nx-2 if the same grid as ARPS
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: ny_wrf ! = ny-2 if the same grid as ARPS
INTEGER, INTENT(OUT) :: nz_wrf ! = nz-2 if the same grid as ARPS
! All are staggered values
REAL, INTENT(OUT) :: lattru_wrf(2) ! array of true latitude of WRF map projection
REAL, INTENT(OUT) :: lontru_wrf ! true longitude of WRF map projection
! = trulon_wrf
! Namelist variable declaration
CHARACTER(LEN=7), DIMENSION(nmax_domains), INTENT(OUT) :: sfcinitopt
CHARACTER(LEN=19), DIMENSION(nmax_domains), INTENT(OUT) :: start_date
CHARACTER(LEN=256), INTENT(OUT) :: geogdir
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: wrftrnopt
REAL :: silavwt_parm_wrf,toptwvl_parm_wrf
REAL, INTENT(OUT) :: silwt,wvln
INTEGER, INTENT(OUT) :: create_bdy ! Create WRF boundary file
INTEGER, INTENT(OUT) :: create_namelist ! Dump WRF namelist.input
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: use_arps_grid
! Use ARPS horizontal grid as WRF grid
INTEGER, INTENT(OUT) :: tintv_bdywrf ! Desired WRF boundary file interval (in seconds)
CHARACTER(LEN=256) :: bdyfheader ! ARPS boundary input file header
INTEGER :: tbgn_bdyin ! ARPS boundary begin time (in seconds)
INTEGER, INTENT(OUT) :: tintv_bdyin ! ARPS boundary file interval (in seconds)
INTEGER :: tend_bdyin ! Last ARPS boundary file time
INTEGER, INTENT(OUT) :: mgrdbas ! Options for grid base file
! = 0 share same grid base as initial state file
! = 1 All ARPS boundary files share one grd base
! file but it is difference from the inital
! base file as specified using grdbasfn
! = 2 Each file has its own grid base file
CHARACTER(LEN=256), INTENT(OUT) :: wrfnamelist ! file name for WRF namelist.input
INTEGER, INTENT(OUT) :: mapproj_wrf ! Type of map projection in WRF model grid
! modproj = 1 Polar Stereographic
! projection.
! = 2 Mercator projection.
! = 3 Lambert projection.
REAL, INTENT(OUT) :: sclfct_wrf ! Map scale factor.
! Distance on map, between two latitudes
! trulat1 and trulat2,
! is = (Distance on earth)*sclfct.
! For ARPS model runs,
! generally this is 1.0
REAL :: trulat1_wrf, trulat2_wrf, trulon_wrf
! 1st, 2nd real true latitude and true longitude
! of WRF map projection
REAL, INTENT(OUT) :: ctrlat_wrf ! Center latitude of WRF model domain (deg. N)
REAL, INTENT(OUT) :: ctrlon_wrf ! Center longitude of WRF model domain (deg. E)
REAL, DIMENSION(nmax_domains), INTENT(OUT) :: dx_wrf ! WRF Grid spacing in x-direction
REAL, DIMENSION(nmax_domains), INTENT(OUT) :: dy_wrf ! WRF Grid spacing in y-direction
INTEGER :: vertgrd_opt ! WRF sigma level scheme
REAL, DIMENSION(nmax_domains), INTENT(OUT) :: ptop ! WRF atmosphere top pressure in Pascal
REAL :: pbot
REAL, INTENT(OUT) :: zlevels_wrf(max_vertical_levels)
! WRF mass levels from 1.0 at surfact to
! 0.0 at atmosphere top
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: i_parent_start
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: j_parent_start
INTEGER, INTENT(OUT) :: iorder ! order of polynomial for horizontal
! interpolation (1 or 2)
INTEGER, INTENT(OUT) :: korder ! vertical interpolation order (1 or 2)
INTEGER :: dyn_opt ! WRF dynamics option
! only works for = 2 Eulerian mass coordinate
INTEGER, INTENT(OUT) :: diff_opt ! WRF diffusion option
INTEGER, INTENT(OUT) :: km_opt ! WRF eddy coefficient option
REAL, DIMENSION(nmax_domains), INTENT(OUT) :: khdif ! Horizontal diffusion constant (m^2/s)
REAL, DIMENSION(nmax_domains), INTENT(OUT) :: kvdif ! Vertical diffusion constant (m^2/s)
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: mp_physics ! WRF microphysics options
!= 2 Lin et al. scheme
! (QVAPOR,QRAIN,QSNOW,QCLOUD,QICE,QGRAUP)
!= 3 NCEP 3-class simple ice scheme
! (QVAPOR,QCLOUD,QICE,QRAIN,QSNOW)
!= 4 NCEP 5-class scheme
! (QVAPOR,QCLOUD,QICE,QRAIN,QSNOW)
!= 5 Ferrier (new Eta) microphysics
! (QVAPOR,QCLOUD)
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: ra_lw_physics ! Longwave radiaiton option
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: ra_sw_physics ! Shortwave radiation option
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: sf_sfclay_physics ! WRF surface-layer option
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: sf_surface_physics ! WRF land-surface option
! = 0 no land-surface
! (DO NOT use)
! = 1 Thermal diffusion scheme
! (nzsoil_wrf = 5)
! = 2 OSU land-surface model
! (nzsoil_wrf = 4)
! = 3 Do not use
! (nzsoil_wrf = 6)
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: bl_pbl_physics ! boundary-layer option
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: cu_physics ! cumulus option
REAL, INTENT(OUT) :: dt ! time-step for advection
INTEGER, INTENT(OUT) :: spec_bdy_width ! number of rows for specified boundary values nudging
REAL, INTENT(OUT) :: base_pres, base_temp, base_lapse
INTEGER, INTENT(OUT) :: nprocx_wrf ! Number of X direction processors for WRF run
INTEGER, INTENT(OUT) :: nprocy_wrf ! Number of Y direction processors for WRF run
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: frames_per_outfile
REAL, DIMENSION(nmax_domains), INTENT(OUT) :: radt,cudt
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: parent_time_step_ratio
INTEGER, INTENT(OUT) :: restart_interval
INTEGER, INTENT(OUT) :: ifsnow, w_damping
INTEGER, INTENT(OUT) :: io_form
INTEGER, INTENT(OUT) :: qx_zero_out
INTEGER, INTENT(OUT) :: max_dom
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: parent_id
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: hinfmt
CHARACTER(LEN=256), DIMENSION(nmax_domains), INTENT(OUT) :: adashisfn, adasbasfn
CHARACTER(LEN=256), DIMENSION(nmax_domains), INTENT(OUT) :: sfcdtfn
LOGICAL, DIMENSION(nmax_domains), INTENT(OUT) :: input_from_file
NAMELIST /message_passing/nproc_x, nproc_y, readsplit, nprocx_in, nprocy_in
NAMELIST /domains/ max_dom,parent_id,input_from_file
NAMELIST /history_data/ hinfmt, adasbasfn, adashisfn
NAMELIST /sfcdt/ sfcinitopt,wrftrnopt,sfcfmt,sfcdtfn, &
geogdir,silavwt_parm_wrf,toptwvl_parm_wrf,start_date
NAMELIST /bdyspc/ create_bdy,tintv_bdywrf,bdyfheader,tbgn_bdyin, &
tintv_bdyin,tend_bdyin,mgrdbas
REAL :: max_dz
NAMELIST /wrf_grid/ use_arps_grid,nx_wrf,ny_wrf, &
mapproj_wrf, sclfct_wrf, &
trulat1_wrf, trulat2_wrf,trulon_wrf, &
ctrlat_wrf, ctrlon_wrf, &
dx_wrf, dy_wrf, i_parent_start, j_parent_start, &
ptop,vertgrd_opt,nz_wrf,pbot,zlevels_wrf,max_dz
NAMELIST /interp_options/ iorder, korder
INTEGER, INTENT(OUT) :: io_form_history, io_form_restart
CHARACTER(LEN=256), INTENT(OUT) :: staticdir,indir, outdir
LOGICAL, INTENT(OUT) :: pd_moist
INTEGER, DIMENSION(nmax_domains), INTENT(OUT) :: history_interval
NAMELIST /wrf_opts/ diff_opt, km_opt, khdif, kvdif, &
mp_physics, ra_lw_physics, ra_sw_physics, &
sf_sfclay_physics, sf_surface_physics, &
bl_pbl_physics, cu_physics, &
base_pres,base_temp, base_lapse,dt, &
spec_bdy_width, nprocx_wrf, nprocy_wrf, &
frames_per_outfile,restart_interval,radt,cudt, &
ifsnow, w_damping, parent_time_step_ratio, &
io_form_history,io_form_restart,history_interval, &
indir,outdir,staticdir,pd_moist
NAMELIST /output/ dirname,readyfl,io_form,qx_zero_out, &
create_namelist,wrfnamelist
!-----------------------------------------------------------------------
!
! Misc local variables
!
!-----------------------------------------------------------------------
!
INTEGER :: i,j,k,n,ifile
INTEGER :: lenstr, ireturn
INTEGER :: domid
LOGICAL :: fexist
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!-----------------------------------------------------------------------
!
! Read mpi related block
!
!-----------------------------------------------------------------------
nproc_x = 1
nproc_y = 1
readsplit = 1
nprocx_in = 1
nprocy_in = 1
IF(myproc == 0) THEN
READ(5,message_passing)
WRITE(6,'(a)')'Namelist message_passing was successfully read.'
END IF
CALL mpupdatei
(nproc_x,1)
CALL mpupdatei(nproc_y,1)
CALL mpupdatei(readsplit,1)
IF(readsplit > 0) THEN
nprocx_in = nproc_x
nprocy_in = nproc_y
END IF
CALL mpupdatei(nprocx_in,1)
CALL mpupdatei(nprocy_in,1)
ncompressx = nprocx_in/nproc_x
ncompressy = nprocy_in/nproc_y
IF (mp_opt > 0 .AND. ( &
(MOD(nprocx_in,nproc_x) /= 0 .OR. MOD(nprocy_in,nproc_y) /= 0) &
.OR. (ncompressx < 1 .OR. ncompressy < 1) ) ) THEN
IF (myproc == 0) WRITE(6,'(3x,a/,2(3x,2(a,I2)/))') &
'nprocx_in (nprocy_in) must be a multiplier of nproc_x(nproc_y).',&
'nprocx_in = ',nprocx_in, ', nprocy_in = ',nprocy_in, &
'nproc_x = ',nproc_x, ', nproc_y = ',nproc_y
CALL arpsstop('unmatched dimension size.',1);
END IF
IF (mp_opt == 0) THEN
ncompressx = 1
ncompressy = 1
nproc_x = 1
nproc_y = 1
nprocx_in = 1
nprocy_in = 1
myproc = 0
loc_x = 1
loc_y = 1
readsplit = 0
ELSE
CALL mpinit_var
END IF
max_dom = 1
parent_id = 1
input_from_file = .TRUE.
IF(myproc == 0) THEN
READ(5,domains)
WRITE(6,'(a)')'Namelist domains was successfully read.'
END IF
CALL mpupdatei(max_dom, 1)
CALL mpupdatei(parent_id, nmax_domains)
CALL mpupdatel(input_from_file,nmax_domains)
IF (.NOT. input_from_file(1)) THEN
WRITE(6,'(1x,a)') 'ERROR: input_from_file for domain 1 must be .TRUE..'
CALL arpsstop('Wrong input_from_file in domains.',1)
END IF
!
!-----------------------------------------------------------------------
!
! Get the names of the input data files.
!
!-----------------------------------------------------------------------
!
IF(myproc == 0) THEN
READ(5,history_data)
WRITE(6,'(a)') 'Namelist history_data was successfully read.'
WRITE(6,'(2x,a6,a36,a36)') 'Domain',' ADAS file ',' Grid BASE file '
WRITE(6,'(2x,a6,a36,a36)') '======','==============','=================='
DO domid = 1, max_dom
IF (input_from_file(domid)) &
WRITE(6,'(2x,I3,a3,a36,a36)') domid,': ',TRIM(adashisfn(domid)),TRIM(adasbasfn(domid))
END DO
WRITE(6,*)
hisfile(1) = adashisfn(1)
bdybasfn(1) = adasbasfn(1)
END IF
CALL mpupdatei(hinfmt,nmax_domains)
CALL mpupdatec(adashisfn,256*nmax_domains)
CALL mpupdatec(adasbasfn,256*nmax_domains)
finexist(:) = 0
nhisfile = 1
finexist(1) = 1
!-----------------------------------------------------------------------
!
! Now get ARPS dimensions for program ARPS2WRF
!
!-----------------------------------------------------------------------
IF (progopt == 0) THEN
DO domid = 1,max_dom
IF (input_from_file(domid)) THEN
IF(mp_opt > 0 .AND. readsplit <= 0) THEN
WRITE(grdbasfn,'(a,a,2i2.2)') TRIM(adasbasfn(domid)),'_',loc_x,loc_y
ELSE
WRITE(grdbasfn,'(a)') TRIM(adasbasfn(domid))
END IF
lengbf = len_trim(grdbasfn)
IF (myproc == 0) THEN
CALL get_dims_from_data(hinfmt(domid),grdbasfn(1:lengbf), &
nx(domid),ny(domid),nz(domid),nzsoil(domid),nstyps(domid),ireturn)
END IF
CALL mpupdatei(ireturn,1)
IF( ireturn /= 0 ) THEN
PRINT*,'Problem occured when trying to get dimensions from data.'
PRINT*,'Program stopped.'
CALL arpsstop('get_dims_from_data error.',1)
END IF
END IF
END DO
CALL mpupdatei(nx, nmax_domains)
CALL mpupdatei(ny, nmax_domains)
CALL mpupdatei(nz, nmax_domains)
CALL mpupdatei(nzsoil,nmax_domains)
CALL mpupdatei(nstyps,nmax_domains)
ELSE ! wrfstatic does not use ARPS dimensions so far
nx = 1
ny = 1
nz = 1
nzsoil = 1
nstyps = 1
END IF
!----------------------------------------------------------------------
!
! Get surface characteristics file options
!
!----------------------------------------------------------------------
!
sfcinitopt(:)(1:7)= ' '
sfcfmt = 1
sfcdtfn(:)(1:256) = ' '
wrftrnopt(:) = 0
geogdir(1:256) = ' '
start_date(:) = '1998-05-25_00:00:00'
silavwt_parm_wrf = 0.0
toptwvl_parm_wrf = 2.0
IF (myproc == 0) THEN
READ(5,sfcdt)
WRITE(6,'(a)') 'Namelist sfcdt was successfully read.'
IF (progopt == 0) THEN
DO domid = 1,max_dom
IF (input_from_file(domid)) THEN
IF (sfcinitopt(domid) == 'ARPS' .AND. mp_opt > 0 .AND. readsplit == 0) THEN
WRITE(grdbasfn,'(2a,2I2.2)') TRIM(sfcdtfn(domid)),'_',loc_x,loc_y
ELSE
WRITE(grdbasfn,'(a)') TRIM(sfcdtfn(domid))
END IF
INQUIRE(FILE=trim(grdbasfn), EXIST = fexist )
IF(.NOT. fexist) THEN
WRITE(6,*) 'The file ',TRIM(grdbasfn),' you specified does not exist.'
CALL arpsstop('File does not exist.',1)
END IF
END IF ! input_from_file
END DO
END IF
END IF
lenstr = LEN_TRIM(geogdir)
IF (geogdir(lenstr:lenstr) /= '/') THEN
lenstr = lenstr + 1
geogdir(lenstr:lenstr) = '/'
END IF
silwt = silavwt_parm_wrf
wvln = toptwvl_parm_wrf
CALL mpupdatei(sfcfmt,1)
CALL mpupdatec(sfcinitopt, 7*nmax_domains)
CALL mpupdatec(sfcdtfn, 256*nmax_domains)
!----------------------------------------------------------------------
!
! Get boundary file specifications
!
!----------------------------------------------------------------------
!
create_bdy = 0
tintv_bdywrf = 10800
bdyfheader = './eta25may1998'
tbgn_bdyin = 10800
tintv_bdyin= 10800
tend_bdyin = 21600
mgrdbas = 0
n = 0
IF (myproc == 0) THEN
READ(5,bdyspc)
WRITE(6,'(a)') 'Namelist bdyspc was successfully read.'
IF(create_bdy >= 1 .AND. progopt == 0) THEN
IF(tintv_bdyin < 1) THEN
WRITE(6,'(/a,I6,a/)') 'ERROR: Boudnary interval (tintv_bdyin =', &
tintv_bdyin,') is not correct. Terminating ...'
CALL arpsstop('Wrong namelist input parameters.',1)
END IF
n = 1
! IF (create_bdy == 1) tintv_bdywrf = tintv_bdyin
DO i = tbgn_bdyin,tend_bdyin,tintv_bdyin
nhisfile = nhisfile + 1
WRITE(hisfile(nhisfile),'(2a,I6.6)') &
TRIM(bdyfheader),finfmt(hinfmt(1)),i
finexist(nhisfile) = 1
IF (mp_opt > 0 .AND. readsplit <= 0 ) THEN
WRITE(grdbasfn,'(a,a,2i2.2)') TRIM(hisfile(nhisfile)),'_',loc_x,loc_y
ELSE
WRITE(grdbasfn,'(a)') hisfile(nhisfile) ! used as temporary string
END IF
INQUIRE(FILE=trim(grdbasfn), EXIST = fexist )
IF(.NOT. fexist) THEN
WRITE(6,'(/1x,3a,I6,a/)') 'WARNING: The file ',TRIM(grdbasfn), &
' does not exist. Boundary file at ',i,' was skipped.'
finexist(nhisfile) = 0
!nhisfile = nhisfile - 1
!CYCLE
!CALL arpsstop('File does not exist.',1)
END IF
IF(mgrdbas == 1 .AND. nhisfile == 2) THEN
WRITE(bdybasfn(nhisfile),'(3a)') &
TRIM(bdyfheader),finfmt(hinfmt(1)),'grdbas'
n = 2 ! maximum index when checking the existance of grid and base file
ELSE IF(mgrdbas > 1) THEN
WRITE(bdybasfn(nhisfile),'(3a,I2.2)') &
TRIM(bdyfheader),finfmt(hinfmt(1)),'grdbas.',nhisfile-1
n = nhisfile
END IF
END DO
END IF ! create_bdy == 1
!
! Check grid and base file availability
! only do check for the root processor because nproc_x may not equal nprocx_in
!
DO i = 1,n
IF (mp_opt > 0 .AND. readsplit <= 0 ) THEN
WRITE(grdbasfn,'(a,a,2i2.2)') TRIM(bdybasfn(i)),'_',loc_x,loc_y
ELSE
WRITE(grdbasfn,'(a)') TRIM(bdybasfn(i)) ! used as temporary string
END IF
INQUIRE(FILE=trim(grdbasfn), EXIST = fexist )
IF(.NOT. fexist) THEN
WRITE(6,'(1x,3a)') 'WARNING: The ARPS grid and base file ',TRIM(grdbasfn),' does not exist.'
IF (i == 1) THEN ! grid & base file must be exist for the first time level
CALL arpsstop('File does not exist.',1)
ELSE IF (finexist(i) == 1) THEN ! the history data exsit
finexist(i) = 0
WRITE(6,'(10x,a,I2,a,/,10x,a,/,10x,a,I2,a)') &
'The boundary data at time level ',i,' is skipped.', &
'Actually, for better results, you can avoid this by specifying mgrdbas = 0/1,', &
'since the time dependent data file at time level ',i,' is available.'
!ELSE ! the history data is also not exist
END IF
END IF
END DO
END IF ! myproc == 0
CALL mpupdatei(n,1)
CALL mpupdatei(nhisfile,1)
CALL mpupdatec(bdybasfn,nhisfile_max*256) ! does not include processor app.
CALL mpupdatec(hisfile, nhisfile_max*256)
CALL mpupdatei(create_bdy,1)
CALL mpupdatei(mgrdbas, 1)
CALL mpupdatei(tintv_bdywrf,1)
CALL mpupdatei(tintv_bdyin,1)
CALL mpupdatei(finexist,nhisfile_max)
!-----------------------------------------------------------------------
!
! Get WRF grid options
!
!-----------------------------------------------------------------------
!
use_arps_grid = 0
nx_wrf = nx-2
ny_wrf = ny-2
i_parent_start = 1
j_parent_start = 1
ptop = 5000
pbot = 101300
vertgrd_opt = 0
nz_wrf = 31
zlevels_wrf = -1.0
max_dz = 1000.
IF (myproc == 0) THEN
READ(5,wrf_grid)
WRITE(6,'(a)') 'Namelist wrf_grid was successfully read.'
DO domid = 1, max_dom
IF(use_arps_grid(domid) == 1 .AND. progopt == 0 .AND. input_from_file(domid)) THEN
WRITE(6,'(/,3(1x,a/))') &
'***** You have chosen to use ARPS grid in the data as your ******', &
'***** WRF grid. Please note that the two fake points in each ******', &
'***** direction of ARPS grid are not used. ******'
IF (mp_opt > 0) THEN
IF( readsplit > 0 ) THEN
IF( MOD(nx(domid)-fzone_arps,nproc_x) /= 0 .OR. &
MOD(ny(domid)-fzone_arps,nproc_y) /= 0) THEN
WRITE(6,'(a/,a/,4(a,i5))') &
'The specification of nproc_x or nproc_y is not matched with nx or ny.',&
'nx-3 and ny-3 must be multiples of nproc_x and nproc_y respectively.', &
'nx = ', nx(domid), ' ny = ', ny(domid), ' nproc_x = ',nproc_x, ' nproc_y = ',nproc_y
nx(domid) = 0
ny(domid) = 0 ! to be exit later
ELSE
nx(domid) = (nx(domid)-fzone_arps)/nproc_x + fzone_arps
ny(domid) = (ny(domid)-fzone_arps)/nproc_y + fzone_arps
END IF
ELSE
nx(domid) = (nx(domid)-fzone_arps)*ncompressx + fzone_arps
ny(domid) = (ny(domid)-fzone_arps)*ncompressy + fzone_arps
END IF
END IF
WRITE(6,'(5(a,i5))') ' nx = ',nx(domid),', ny = ',ny(domid),', nz = ',nz(domid), &
', nzsoil = ',nzsoil(domid),', nstyps = ',nstyps(domid)
nx_wrf(domid) = nx(domid) - 2
ny_wrf(domid) = ny(domid) - 2
ELSE IF (mp_opt > 0) THEN
WRITE(6,'(1x,2a,/,a,/,2a,/,a,/,a)') 'WARNING: At present, ', &
'arps2wrf_mpi only works when WRF horizontal grid and', &
' ARPS horizontal grid are the same.', 'Please set ', &
'use_arps_grid = 1 in arps2wrf.input.', &
'Or use no-mpi version of arps2wrf.', &
' Program stopping ...'
CALL arpsstop('MPI mode does not work.',1)
END IF
END DO ! max_dom
END IF ! myproc == 0
CALL mpupdatei(nx, nmax_domains)
CALL mpupdatei(ny, nmax_domains)
CALL mpupdatei(nz, nmax_domains)
CALL mpupdatei(nzsoil,nmax_domains)
CALL mpupdatei(nstyps,nmax_domains)
DO domid = 1,max_dom
IF (input_from_file(domid)) THEN
IF( nx(domid) <= 0 .OR. ny(domid) <= 0 ) CALL arpsstop('Wrong size of dimensions.',1);
ELSE
nx(domid) = -1
ny(domid) = -1
END IF
END DO
nstyp = nstyps(1)
CALL mpupdatei(nx_wrf, nmax_domains)
CALL mpupdatei(ny_wrf, nmax_domains)
CALL mpupdatei(i_parent_start,nmax_domains)
CALL mpupdatei(j_parent_start,nmax_domains)
CALL mpupdatei(nz_wrf,1)
CALL mpupdatei(use_arps_grid, nmax_domains)
CALL mpupdater(ptop, nmax_domains)
CALL mpupdater(zlevels_wrf,max_vertical_levels)
!
! Map projection parameters do not need to be updated because
! use_arps_grid must be 1 for mpi job
!
lattru_wrf(1) = trulat1_wrf
lattru_wrf(2) = trulat2_wrf
lontru_wrf = trulon_wrf
!-----------------------------------------------------------------------
!
! Get WRF options (NetCDF file needs them for global attributes)
!
!-----------------------------------------------------------------------
dyn_opt = 2
! IF(dyn_opt /= 2) THEN
! WRITE(6,*) 'NOTE: ARPS2WRF only works for WRF MASS core at present'
! WRITE(6,*) ' dyn_opt has been reseted to 2.'
! END IF
diff_opt = 0
km_opt = 1
khdif = 0.0
kvdif = 0.0
mp_physics = 1 ! must be specified, used for moist variable determination
ra_lw_physics = 1
ra_sw_physics = 1
sf_sfclay_physics = 1
sf_surface_physics = 1 ! must be specified, used for soil layer determination
bl_pbl_physics = 1
cu_physics = 1
base_pres = 100000.
base_temp = 290.
base_lapse = 50.
dt = 40
spec_bdy_width = 5
nprocx_wrf = -1 ! only root processor write namelist parameters
nprocy_wrf = -1
frames_per_outfile = 1
restart_interval = 60
radt = 30.
cudt = 0.
ifsnow = 0
w_damping = 0
parent_time_step_ratio = 1
io_form_history = 2
io_form_restart = 2
history_interval(:)= 60
indir = './'
outdir = './'
staticdir = './'
pd_moist = .FALSE.
IF (myproc == 0) THEN
READ(5,wrf_opts)
WRITE(6,'(a)') 'Namelist wrf_opts was successfully read.'
IF(progopt == 0 ) THEN
DO domid = 1,max_dom
IF (sf_surface_physics(domid) > 3 .OR. sf_surface_physics(domid) < 1 ) THEN
WRITE(6,*) 'Not a valid sf_surface_physics option - ',sf_surface_physics
WRITE(6,*) 'It must be either 1, 2 or 3.'
CALL arpsstop('Bad WRF namelist parameters inside arps2wrf.input.',1)
END IF
IF ( (bl_pbl_physics(domid) == 2 .AND. sf_sfclay_physics(domid) /= 2) .OR. &
(bl_pbl_physics(domid) /= 2 .AND. sf_sfclay_physics(domid) == 2) ) THEN
WRITE(6,'(1x,2(a,/))') &
'MYJ PBL scheme requires a matched sfclay scheme.', &
'Please check sf_sfclay_physics in the namelist file.'
CALL arpsstop('Not matched sfclay and pbl options.',1)
END IF
END DO
END IF
lenstr = LEN_TRIM(staticdir)
IF(lenstr > 0) THEN
IF(staticdir(lenstr:lenstr) /= '/') THEN
staticdir(lenstr+1:lenstr+1) = '/'
lenstr = lenstr + 1
END IF
ELSE
staticdir = './'
END IF
lenstr = LEN_TRIM(indir)
IF(lenstr > 0) THEN
IF(indir(lenstr:lenstr) /= '/') THEN
indir(lenstr+1:lenstr+1) = '/'
lenstr = lenstr + 1
END IF
ELSE
indir = './'
END IF
lenstr = LEN_TRIM(outdir)
IF(lenstr > 0) THEN
IF(outdir(lenstr:lenstr) /= '/') THEN
outdir(lenstr+1:lenstr+1) = '/'
lenstr = lenstr + 1
END IF
ELSE
outdir = './'
END IF
END IF
CALL mpupdatei(mp_physics,nmax_domains)
CALL mpupdatei(sf_surface_physics,nmax_domains)
CALL mpupdatei(spec_bdy_width,1)
CALL mpupdater(base_temp,1)
!-----------------------------------------------------------------------
!
! Compute vertical levels based on user's choice
!
!-----------------------------------------------------------------------
IF (progopt == 0) THEN ! for ARPS2WRF only
IF (myproc == 0) CALL compute_eta(vertgrd_opt,nz_wrf,max_dz, &
pbot,ptop,max_vertical_levels,zlevels_wrf,istatus)
CALL mpupdatei(nz_wrf,1)
CALL mpupdater(zlevels_wrf,max_vertical_levels)
END IF
!
!-----------------------------------------------------------------------
!
! Get interpolation options
!
!-----------------------------------------------------------------------
!
iorder = 3
korder = 2
IF (myproc == 0) THEN
READ(5,interp_options)
WRITE(6,'(a)') 'Namelist interp_options was successfully read.'
END IF
CALL mpupdatei(iorder,1)
CALL mpupdatei(korder,1)
!
!-----------------------------------------------------------------------
!
! Get output options
!
!-----------------------------------------------------------------------
!
dirname = './'
readyfl = 0
create_namelist = 0
IF (myproc == 0) THEN
READ(5,output)
WRITE(6,'(a)') 'Namelist output was successfully read.'
lenstr = LEN_TRIM(dirname)
IF(lenstr > 0) THEN
IF(dirname(lenstr:lenstr) /= '/') THEN
dirname(lenstr+1:lenstr+1) = '/'
lenstr = lenstr + 1
END IF
ELSE
dirname = './'
END IF
END IF
CALL mpupdatei(io_form,1)
CALL mpupdatei(qx_zero_out,1)
!-----------------------------------------------------------------------
!
! Successfully finished with namelist input
!
!-----------------------------------------------------------------------
istatus = 0
RETURN
END SUBROUTINE readnamelist
!#######################################################################
!#######################################################################
!#### ####
!#### SUBROUTINE compute_eta ####
!#### ####
!#######################################################################
!#######################################################################
SUBROUTINE compute_eta(vertgrdopt,nzwrf,maxdz,pbot,ptop,num_max_levels, & 1,5
znw,istatus)
!-----------------------------------------------------------------------
!
! Purpose
! Compute WRF eta levels
!
!-----------------------------------------------------------------------
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: vertgrdopt
INTEGER, INTENT(INOUT) :: nzwrf
REAL, INTENT(IN) :: maxdz
REAL, INTENT(IN) :: pbot, ptop
INTEGER, INTENT(IN) :: num_max_levels
REAL, INTENT(INOUT) :: znw(num_max_levels)
INTEGER, INTENT(OUT) :: istatus
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
INTEGER :: nlevels
INTEGER :: k
REAL :: sigma1, sigma2, plevel1, plevel2
LOGICAL :: compute_const_dz = .FALSE.
INTEGER , PARAMETER :: prac_levels = 17
REAL, DIMENSION(prac_levels) :: znw_prac, znu_prac, dnw_prac
REAL :: p00, t00, a, pb, p_surf, temp, t_init
REAL :: alb(nzwrf), phb(nzwrf)
REAL :: mub, ztop, ztop_pbl, dz
INTEGER :: loop, loop1
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Begin of executable code below
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
IF(vertgrdopt == 0) THEN
!-----------------------------------------------------------------------
!
! Check the validation of vertical level specifications
!
!-----------------------------------------------------------------------
! Make sure first value is 1.0
IF (znw(1) /= 1.0) THEN ! User ask us to compute znw
! nzwrf is used here.
! WRITE(6,'(A,F6.3)') 'Bad first level: ',zlevels_wrf(1)
! WRITE(6,'(A)') 'Mass coordinate must range from 1.0 at ' &
! //'surface to 0.0 at top.'
! CALL arpsstop('Bad WRF vertical levels.',1)
!
! Compute eta levels assuming a constant delta z above the PBL.
!
compute_const_dz = .TRUE.
p00 = base_pres
t00 = base_temp
a = base_lapse
! Compute top of the atmosphere with some silly levels. We just want to
! integrate to get a reasonable value for ztop. We use the planned PBL-esque
! levels, and then just coarse resolution above that. We know p_top, and we
! have the base state vars.
p_surf = p00
znw_prac = (/ 1.000 , 0.993 , 0.983 , 0.970 , 0.954 , 0.934 , 0.909 , &
0.88 , 0.8 , 0.7 , 0.6 , 0.5 , 0.4 , 0.3 , 0.2 , 0.1 , 0.0 /)
DO k = 1 , prac_levels - 1
znu_prac(k) = ( znw_prac(k) + znw_prac(k+1) ) * 0.5
dnw_prac(k) = znw_prac(k+1) - znw_prac(k)
END DO
DO k = 1, prac_levels-1
pb = znu_prac(k)*(p_surf - ptop) + ptop
temp = t00 + A*LOG(pb/p00)
t_init = temp*(p00/pb)**(r_d/cp_wrf) - t0
alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
END DO
! Base state mu is defined as base state surface pressure minus p_top
mub = p_surf - ptop
! Integrate base geopotential, starting at terrain elevation.
phb(1) = 0.
DO k = 2,prac_levels
phb(k) = phb(k-1) - dnw_prac(k-1)*mub*alb(k-1)
END DO
! So, now we know the model top in meters. Get the average depth above the PBL
! of each of the remaining levels. We are going for a constant delta z thickness.
ztop = phb(prac_levels) / g_wrf
ztop_pbl = phb(8 ) / g_wrf
dz = ( ztop - ztop_pbl ) / REAL ( nzwrf - 8 )
! Standard levels near the surface so no one gets in trouble.
DO k = 1 , 8
znw(k) = znw_prac(k)
END DO
! Using d phb(k)/ d eta(k) = -mub * alb(k), eqn 2.9
! Skamarock et al, NCAR TN 468. Use full levels, so
! use twice the thickness.
DO k = 8, nzwrf-1
pb = znw(k) * (p_surf - ptop) + ptop
temp = t00 + A*LOG(pb/p00)
t_init = temp*(p00/pb)**(r_d/cp_wrf) - t0
alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
znw(k+1) = znw(k) - dz*g_wrf / ( mub*alb(k) )
END DO
znw(nzwrf) = 0.000
! There is some iteration. We want the top level, ztop, to be
! consistent with the delta z, and we want the half level values
! to be consistent with the eta levels. The inner loop to 10 gets
! the eta levels very accurately, but has a residual at the top, due
! to dz changing. We reset dz five times, and then things seem OK.
DO loop1 = 1 , 5
DO loop = 1 , 10
DO k = 8, nzwrf-1
pb = (znw(k)+znw(k+1))*0.5 * (p_surf - ptop) + ptop
temp = t00 + A*LOG(pb/p00)
t_init = temp*(p00/pb)**(r_d/cp_wrf) - t0
alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
znw(k+1) = znw(k) - dz*g_wrf / ( mub*alb(k) )
END DO
IF ( ( loop1 .EQ. 5 ) .AND. ( loop .EQ. 10 ) ) THEN
print *,'Converged znw(kte) should be 0.0 = ',znw(nzwrf)
END IF
znw(nzwrf) = 0.000
END DO
! Here is where we check the eta levels values we just computed.
DO k = 1, nzwrf-1
pb = (znw(k)+znw(k+1))*0.5 * (p_surf - ptop) + ptop
temp = t00 + A*LOG(pb/p00)
t_init = temp*(p00/pb)**(r_d/cp_wrf) - t0
alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
END DO
phb(1) = 0.
DO k = 2,nzwrf
phb(k) = phb(k-1) - (znw(k)-znw(k-1)) * mub*alb(k-1)
END DO
! Reset the model top and the dz, and iterate.
ztop = phb(nzwrf)/g_wrf
ztop_pbl = phb(8)/g_wrf
dz = ( ztop - ztop_pbl ) / REAL ( nzwrf - 8 )
END DO
IF ( dz .GT. maxdz ) THEN
print *,'z (m) = ',phb(1)/g_wrf
do k = 2 ,nzwrf
print *,'z (m) and dz (m) = ',phb(k)/g_wrf,(phb(k)-phb(k-1))/g_wrf
end do
print *,'dz (m) above fixed eta levels = ',dz
print *,'namelist max_dz (m) = ',maxdz
print *,'namelist p_top (Pa) = ',ptop
WRITE( 0, '(2x,a)') 'You need one of three things:'
WRITE( 0, '(4x,a)') '1) More eta levels to reduce the dz: e_vert'
WRITE( 0, '(4x,a)') '2) A lower p_top so your total height is reduced: p_top_requested'
WRITE( 0, '(4x,a)') '3) Increase the maximum allowable eta thickness: max_dz'
WRITE( 0, '(7x,a)') 'All are namelist options'
CALL arpsstop ( 'dz above fixed eta levels is too large in compute_eta',1)
END IF
ELSE ! zlevels_wrf was specified explicitly
nzwrf = 0
nlevels = 1
! Make sure things are decreasing to 0.0 from bottom to top.
level_check_loop: &
DO k = 2, num_max_levels
! See if this is a valid level, if so increment nlevels
! and perform additional QC checks
IF (znw(k) >= 0.) THEN
! Check for decreasing value of META (after 2nd value found)
IF (znw(k) >= znw(k-1)) THEN
PRINT '(A,I2,A,I2)', 'Level ',k, 'is >= level ' , k-1
PRINT '(A)', 'Mass must be listed in descending order!'
CALL arpsstop('Bad WRF vertical levels.',1)
ELSE
nlevels = nlevels + 1
END IF
ELSE
IF (nlevels < 2) THEN
PRINT '(A)', 'Not enough levels specified'
CALL arpsstop('Bad WRF vertical levels.',1)
ELSE
nzwrf = nlevels
! Check to make sure top level is 0.0
IF (znw(nzwrf) /= 0.) THEN
PRINT '(A,F6.3)', 'Bad top level value: ',znw(nzwrf)
PRINT '(A)', 'Top level must be 0.0 for Mass Eta.'
CALL arpsstop('Bad WRF vertical levels.',1)
END IF
EXIT level_check_loop
END IF
END IF
END DO level_check_loop
END IF
ELSE IF (vertgrdopt == 1) THEN
IF(nzwrf < 15) nzwrf = 15
DO k = 1,nzwrf
znw(k) = (nzwrf-k) / (nzwrf - 1.)
END DO
ELSE IF (vertgrdopt == 2) THEN
IF(nzwrf < 15) nzwrf = 15
DO k = 1,nzwrf,1
znw(k) = SQRT( (nzwrf-k)/(nzwrf-1.) )
END DO
ELSE IF (vertgrdopt == 3) THEN
IF(nzwrf < 15) nzwrf = 15
nlevels = 1
DO k = 1, nzwrf
sigma1 = (k-1) / (nzwrf-1.)
sigma2 = SQRT( (k-1) /(nzwrf-1.) )
plevel1 = sigma1 * (pbot - ptop) + ptop
plevel2 = sigma2 * (pbot - ptop) + ptop
IF (plevel1 < 33333.33) THEN
znw(nlevels) = sigma1
nlevels = nlevels + 1
END IF
IF (plevel2 > 33333.33) THEN
znw(nlevels) = sigma2
nlevels = nlevels + 1
END IF
END DO
nzwrf = nlevels - 1
WRITE(6,'(a,a,I3)') 'WARNING: the actual number of vertical', &
' levels has been changed to ',nzwrf
!
! Sort the levels in decrease order (bubble sort for simplicity)
!
DO k = 1,nzwrf
DO nlevels = 1, nzwrf-k
IF (znw(nlevels+1) > znw(nlevels) ) THEN
sigma1 = znw(nlevels)
znw(nlevels) = znw(nlevels+1)
znw(nlevels+1) = sigma1
END IF
END DO
END DO
END IF
!
! Ouput vertical levels for testing
!
WRITE(6,'(/1x,2(a,I3),a,/)') 'Number of vertical levels is ',nzwrf, &
', vertical sigma scheme is ',vertgrdopt,'.'
IF (compute_const_dz) THEN
WRITE(6,'(1x,a,/,6(4x,a,F12.3,/))') 'zlevels was computed using:', &
'ptop = ',ptop, 'p00 = ',p00,'t00 = ',t00,'a = ',a, &
'max_dz = ',maxdz,'dz = ',dz
ELSE IF (vertgrdopt == 3) THEN
WRITE(6,'(1x,a,/,2(4x,a,F12.0,/))') 'The parameters used are:', &
'ptop = ',ptop, 'pbot = ',pbot
END IF
WRITE(6,FMT='(1x,a)',ADVANCE='NO') 'levels = '
DO nlevels = 1, nzwrf
IF ( nlevels /= 1 .AND. MOD(nlevels,5) == 1 ) &
WRITE(6,FMT='(10x)',ADVANCE='NO')
WRITE(6,FMT='(F8.5,A1)',ADVANCE='NO') znw(nlevels),', '
IF ( MOD(nlevels,5) == 0 ) WRITE(6,*)
END DO
WRITE(6,*)
istatus = 0
RETURN
END SUBROUTINE compute_eta
SUBROUTINE get_check_grid_ratio(domid,nx_wrf,ny_wrf,dx_wrf,dy_wrf, & 3
dx_wrf_parent, dy_wrf_parent, &
a_small_number,parent_grid_ratio, istatus)
!-----------------------------------------------------------------------
!
! Compute parent_grid_ratio and check its validation
!
!-----------------------------------------------------------------------
IMPLICIT NONE
INTEGER, INTENT(IN) :: domid
INTEGER, INTENT(IN) :: nx_wrf, ny_wrf
REAL, INTENT(IN) :: dx_wrf, dy_wrf
REAL, INTENT(IN) :: dx_wrf_parent, dy_wrf_parent
REAL, INTENT(IN) :: a_small_number
INTEGER, INTENT(OUT) :: parent_grid_ratio
INTEGER, INTENT(OUT) :: istatus
INCLUDE 'mp.inc' ! require variable myproc
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
REAL :: gridratiox, gridratioy
INTEGER :: modx, mody
!-----------------------------------------------------------------------
!
! Beginning of executable code ....
!
!-----------------------------------------------------------------------
gridratiox = dx_wrf_parent / dx_wrf
gridratioy = dy_wrf_parent / dy_wrf
parent_grid_ratio = NINT(gridratiox)
IF ( ABS(gridratiox - gridratioy) > a_small_number) THEN ! ensure to have the same ratio
WRITE(6,'(1x,2(a,F7.2),/,4x,a,2(F12.2,a),/,4x,a,2(F12.2,a))') &
'gridratiox = ',gridratiox,', gridratioy = ',gridratioy, &
'Parent grid has dx_wrf/dy_wrf = ',dx_wrf_parent,' / ',dy_wrf_parent,'.', &
'dx_wrf/dy_wrf = ',dx_wrf, ' / ',dy_wrf,'.'
WRITE(6,'(4x,a,/)') 'parent_grid_ratio is different in x and y direction.'
istatus = -1
RETURN
END IF
IF (ABS(gridratiox-parent_grid_ratio) > a_small_number .OR. &
parent_grid_ratio < 1 .OR. MOD(parent_grid_ratio,2) == 0) THEN
! ensure parent_grid_ratio is odd
WRITE(6,'(1x,2(a,I2),/,4x,a,2(F12.2,a),/,4x,a,2(F12.2,a) )') &
'Parent_grid_ratio = ',parent_grid_ratio,' is not acceptable for domain ',domid, &
'Parent grid has dx_wrf/dy_wrf = ',dx_wrf_parent,' / ',dy_wrf_parent,'.', &
'dx_wrf/dy_wrf = ',dx_wrf, ' / ',dy_wrf,'.'
WRITE(6,'(4x,a,/)') 'parent_grid_ratio must be odd for real-data cases.'
istatus = -2
RETURN
END IF
IF (myproc == 0) WRITE(6,'(/,1x,a,I2,a,I2)') &
'Domain - ',domid,', parent_grid_ratio = ',parent_grid_ratio
IF (domid > 1) THEN
modx = MOD((nx_wrf-1),parent_grid_ratio)
mody = MOD((ny_wrf-1),parent_grid_ratio)
IF ( modx /= 0 .OR. mody /= 0 ) THEN
WRITE(6,'(1x,a,I2,/,2(4x,a,I5,a,I2,a,I2,/))') &
'Both MOD(nx_wrf-1,parent_grid_ratio) and '// &
'MOD(ny_wrf-1,parent_grid_ratio) must be 0 for domain ',domid, &
'MOD(nx_wrf-1,parent_grid_ratio) = MOD(',nx_wrf-1,',', &
parent_grid_ratio,') = ',modx, &
'MOD(ny_wrf-1,parent_grid_ratio) = MOD(',ny_wrf-1,',', &
parent_grid_ratio,') = ',mody
istatus = -3
RETURN
END IF
END IF
istatus = 0
RETURN
END SUBROUTINE get_check_grid_ratio
SUBROUTINE set_mp_physics_variables(domid,mp_physics,istatus) 1,1
!-----------------------------------------------------------------------
!
! PURPOSE:
! Set microphysics variable based on namelist parameter mp_physics
!
! NOTE:
!
! Based on Register.EM in WRFV2.2
!
!-----------------------------------------------------------------------
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: domid
INTEGER, INTENT(IN) :: mp_physics
INTEGER, INTENT(OUT) :: istatus
!-----------------------------------------------------------------------
!
! Begin of executable code below ....
!
!-----------------------------------------------------------------------
P_QV = 0
P_QC = 0
P_QR = 0
P_QI = 0
P_QS = 0
P_QG = 0
num_moist = 0
P_QT = 0
P_QNI = 0
num_scalar = 0
istatus = 0
SELECT CASE (mp_physics)
CASE (0) ! passiveqv
P_QV = 1
num_moist = 1
CASE (1,3,98) ! kesslerscheme, wsm3scheme, ncepcloud3
P_QV = 1
P_QC = 2
P_QR = 3
num_moist = 3
CASE (2,6) ! linscheme, wsm6scheme
P_QV = 1
P_QC = 2
P_QR = 3
P_QI = 4
P_QS = 5
P_QG = 6
num_moist = 6
CASE (4,99) ! wsm5scheme,ncepcloud5
P_QV = 1
P_QC = 2
P_QR = 3
P_QI = 4
P_QS = 5
num_moist = 5
CASE (5) ! etampnew
P_QV = 1
P_QC = 2
P_QR = 3
P_QI = 4
P_QS = 5
P_QG = 6
num_moist = 6
P_QT = 1
num_scalar = 1
CASE (8) ! thompson
P_QV = 1
P_QC = 2
P_QR = 3
P_QI = 4
P_QS = 5
P_QG = 6
num_moist = 6
P_QNI = 1
num_scalar = 1
CASE DEFAULT
istatus = -1
WRITE(6,'(/,1x,2(a,I2),/)') 'ERROR: Wrong parameter - mp_physics = ',&
mp_physics,' for dom - ',domid
END SELECT
RETURN
END SUBROUTINE set_mp_physics_variables