!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE open_output_file ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE open_output_file(filename,filetype,io_form,nx,ny,nz,nzsoil, & 3,4
bdywidth,mp_physics,nout)
!------------------------------------------------------------------
!
! PURPOSE:
!
!------------------------------------------------------------------
IMPLICIT NONE
CHARACTER(LEN=*), INTENT(IN) :: filename
CHARACTER(LEN=*), INTENT(IN) :: filetype
INTEGER, INTENT(INOUT):: io_form
INTEGER, INTENT(IN) :: nx
INTEGER, INTENT(IN) :: ny
INTEGER, INTENT(IN) :: nz
INTEGER, INTENT(IN) :: nzsoil
INTEGER, INTENT(IN) :: bdywidth
INTEGER, INTENT(IN) :: mp_physics
INTEGER, INTENT(OUT) :: nout
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INCLUDE 'mp.inc'
INTEGER :: ifile
INTEGER :: istatus
CHARACTER(LEN=80) :: sysdepinfo
LOGICAL :: initialized
LOGICAL :: LargeFile
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
IF (filetype == 'INPUT') THEN
sysdepinfo = 'DATASET=INPUT'
initialized = .FALSE.
ifile = 1
ELSE IF (filetype == 'STATIC') THEN
sysdepinfo = 'DATASET=STATIC' ! check WRF?
initialized = .FALSE.
ifile = 3
ELSE
sysdepinfo = 'DATASET=BOUNDARY'
initialized = .TRUE.
ifile = 2
END IF
LargeFile = .FALSE.
IF (io_form > 90) LargeFile = .TRUE.
io_form = MOD(io_form,90)
IF (io_form == 5) THEN ! PHDF5 format
! Initialize inside open_phdf5_for_write
CALL open_phdf5_for_write
(filename,sysdepinfo,nout,initialized,istatus)
ELSE IF (io_form == 7) THEN ! NetCDF format
! CAPS own I/O do not need initialization
IF(myproc == 0) CALL open_ncd_for_write(filename,LargeFile,ifile, &
nx,ny,nz,nzsoil,bdywidth,mp_physics,nout,istatus)
CALL mpupdatei(nout,1)
ELSE IF (io_form == 1) THEN ! WRF internal format, binary
IF(.NOT. initialized) CALL ext_int_ioinit( SysDepInfo, istatus )
IF (myproc == 0) CALL ext_int_open_for_write( FileName,0, 0, &
SysDepInfo, nout , iStatus )
CALL mpupdatei(nout,1)
ELSE
WRITE(0,*) 'ERROR: unsupport I/O format ', io_form
istatus = -1
nout = -1
END IF
RETURN
END SUBROUTINE open_output_file
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE close_output_file ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE close_output_file(nch,io_form) 3,2
!
!------------------------------------------------------------------
!
! PURPOSE:
!
! Close the output file.
!
!------------------------------------------------------------------
IMPLICIT NONE
INTEGER, INTENT(IN) :: nch
INTEGER, INTENT(IN) :: io_form
INCLUDE 'mp.inc'
INTEGER :: istatus
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
IF (io_form == 1) THEN ! Call WRF I/O API directly
IF(myproc == 0) CALL ext_int_ioclose( nch, iStatus )
ELSE IF (io_form == 7) THEN ! use CAPS own IO API
IF(myproc == 0) CALL close_ncd_for_write(nch,istatus)
ELSE IF (io_form == 5) THEN ! Call a wraper
CALL close_phdf5_for_write(nch,istatus)
END IF
RETURN
END SUBROUTINE close_output_file
SUBROUTINE io_shutdown(io_form) 3,2
IMPLICIT NONE
INTEGER, INTENT(IN) :: io_form
INTEGER :: istatus
IF (io_form == 1) THEN
CALL ext_int_ioexit(istatus)
ELSE IF (io_form == 5) THEN
CALL shutdown_phdf5_io(istatus)
END IF
RETURN
END SUBROUTINE io_shutdown
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE set_global_meta ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE set_global_meta(nx,ny,nz,execname,times_str,dx,dy,dt, & 2,1
dyn_opt,diff_opt,km_opt,damp_opt, &
khdif,kvdif, &
mp_physics,ra_lw_physics, ra_sw_physics, &
sf_sfclay_physics,sf_surface_physics, &
bl_pbl_physics,cu_physics, &
ctrlat,ctrlon,trulat1,trulat2,trulon, &
year,jday,hour,minute,second,mapproj,global_meta)
!
!------------------------------------------------------------------
!
! PURPOSE:
!
! Initialize WRF global meta data and write as global attributes
! to the NetCDF file.
!
!------------------------------------------------------------------
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: nx,ny,nz
REAL, INTENT(IN) :: dx,dy,dt
CHARACTER(*), INTENT(IN) :: execname
CHARACTER(*), INTENT(IN) :: times_str
INTEGER, INTENT(IN) :: dyn_opt, diff_opt,km_opt, damp_opt
REAL, INTENT(IN) :: khdif,kvdif
INTEGER, INTENT(IN) :: mp_physics,ra_lw_physics,ra_sw_physics
INTEGER, INTENT(IN) :: sf_sfclay_physics,sf_surface_physics
INTEGER, INTENT(IN) :: bl_pbl_physics,cu_physics
REAL, INTENT(IN) :: trulat1,trulat2,trulon,ctrlat,ctrlon
INTEGER, INTENT(IN) :: year,jday,hour,minute,second
INTEGER, INTENT(IN) :: mapproj ! ARPS flag
! = 1, polar projection;
! = 2, Lambert projection;
! = 3, Mercator projection.
TYPE(wrf_global_metadata), INTENT(OUT) :: global_meta
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: map_proj ! WRF flag
! 1 -- LAMBERT CONFORMAL
! 2 -- POLAR STEREOGRAPHIC
! 3 -- MERCATOR
!
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
IF(ABS(mapproj) == 1) THEN
map_proj = 2
ELSE IF(ABS(mapproj) == 2) THEN
map_proj = 1
ELSE IF(ABS(mapproj) == 3) THEN
map_proj = 3
ELSE
WRITE(6,*) 'Unknown map projection, ', mapproj
STOP
END IF
! set global_meta
global_meta%title = 'Output from '//TRIM(execname)//' for WRFV2.1'
global_meta%bt_dimension = nz
global_meta%cen_lon = ctrlon
global_meta%start_date = times_str
global_meta%we_dimension = nx
global_meta%sn_dimension = ny
global_meta%dyn_opt = dyn_opt
global_meta%diff_opt = diff_opt
global_meta%km_opt = km_opt
global_meta%damp_opt = damp_opt
global_meta%khdif = khdif
global_meta%kvdif = kvdif
global_meta%mp_physics = mp_physics
global_meta%ra_lw_physics = ra_lw_physics
global_meta%ra_sw_physics = ra_sw_physics
global_meta%sf_sfclay_physics = sf_sfclay_physics ! sf_sfclay_physics for WRF 2.0
global_meta%sf_surface_physics = sf_surface_physics ! sf_surface_physics for WRF 2.0
global_meta%bl_pbl_physics = bl_pbl_physics
global_meta%cu_physics = cu_physics
global_meta%we_p_unstag_s = 1
global_meta%we_p_unstag_e = nx-1
global_meta%we_p_stag_s = 1
global_meta%we_p_stag_e = nx
global_meta%sn_p_unstag_s = 1
global_meta%sn_p_unstag_e = ny-1
global_meta%sn_p_stag_s = 1
global_meta%sn_p_stag_e = ny
global_meta%bt_p_unstag_s = 1
global_meta%bt_p_unstag_e = nz-1
global_meta%bt_p_stag_s = 1
global_meta%bt_p_stag_e = nz
global_meta%dx = dx
global_meta%dy = dy
global_meta%dt = dt
global_meta%cen_lat = ctrlat
global_meta%stand_lon = trulon
global_meta%moad_cen_lat = ctrlat
global_meta%tru_lat1 = trulat1
global_meta%tru_lat2 = trulat2
global_meta%gmt = hour + minute/60. + second/3600.
global_meta%julyr = year
global_meta%julday = jday
global_meta%mminlu = 'USGS' ! 'UMD' What is it???
global_meta%grid_id = 1 ! Added since WRFV2.1
global_meta%parent_id = 0
global_meta%i_parent_start = 0
global_meta%j_parent_start = 0
global_meta%parent_grid_ratio = 1
IF (global_meta%mminlu == 'UMD') THEN
global_meta%iswater = ISWATER_UMD
global_meta%isice = ISICE_UMD
global_meta%isurban = ISURBAN_UMD
ELSE
global_meta%iswater = ISWATER
global_meta%isice = ISICE
global_meta%isurban = ISURBAN
END IF
global_meta%isoilwater = ISWATER_SOIL
global_meta%map_proj = map_proj
RETURN
END SUBROUTINE set_global_meta
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE write_global_attribute ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE write_global_attribute(nfid,io_form,global_meta,bdyflg) 2,58
!
!------------------------------------------------------------------
!
! PURPOSE:
!
! Initialize WRF global meta data and write as global attributes
! to the NetCDF file.
!
!------------------------------------------------------------------
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: nfid
INTEGER, INTENT(IN) :: io_form
TYPE(wrf_global_metadata), INTENT(IN) :: global_meta
LOGICAL, INTENT(IN) :: bdyflg
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: istatus
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
IF (io_form == 7) CALL enter_ncd_define(nfid,istatus)
CALL put_dom_ti_char(nfid,io_form,'TITLE',global_meta%title,istatus)
CALL put_dom_ti_char(nfid,io_form,'START_DATE', &
global_meta%start_date(1:19),istatus)
CALL put_dom_ti_integer(nfid,io_form,'WEST-EAST_GRID_DIMENSION', &
global_meta%we_dimension, istatus)
CALL put_dom_ti_integer(nfid,io_form,'SOUTH-NORTH_GRID_DIMENSION', &
global_meta%sn_dimension, istatus)
CALL put_dom_ti_integer(nfid,io_form,'BOTTOM-TOP_GRID_DIMENSION', &
global_meta%bt_dimension, istatus)
CALL put_dom_ti_real (nfid,io_form, 'DX',global_meta%dx,istatus)
CALL put_dom_ti_real (nfid,io_form, 'DY',global_meta%dy,istatus)
CALL put_dom_ti_char(nfid,io_form,'GRIDTYPE','C', istatus)
CALL put_dom_ti_integer(nfid,io_form,'DYN_OPT', &
global_meta%dyn_opt,istatus)
CALL put_dom_ti_integer(nfid,io_form,'DIFF_OPT', &
global_meta%diff_opt,istatus)
CALL put_dom_ti_integer(nfid,io_form,'KM_OPT', &
global_meta%km_opt,istatus)
CALL put_dom_ti_integer(nfid,io_form,'DAMP_OPT', &
global_meta%damp_opt,istatus)
CALL put_dom_ti_real (nfid,io_form,'KHDIF', &
global_meta%khdif,istatus)
CALL put_dom_ti_real (nfid,io_form, 'KVDIF', &
global_meta%kvdif,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'MP_PHYSICS', &
global_meta%mp_physics,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'RA_LW_PHYSICS', &
global_meta%ra_lw_physics,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'RA_SW_PHYSICS', &
global_meta%ra_sw_physics,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'SF_SFCLAY_PHYSICS', &
global_meta%sf_sfclay_physics,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'SF_SURFACE_PHYSICS', &
global_meta%sf_surface_physics,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'BL_PBL_PHYSICS', &
global_meta%bl_PBL_physics,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'CU_PHYSICS', &
global_meta%cu_physics,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'WEST-EAST_PATCH_START_UNSTAG',&
global_meta%we_p_unstag_s,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'WEST-EAST_PATCH_END_UNSTAG', &
global_meta%we_p_unstag_e,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'WEST-EAST_PATCH_START_STAG', &
global_meta%we_p_stag_s,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'WEST-EAST_PATCH_END_STAG', &
global_meta%we_p_stag_e,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'SOUTH-NORTH_PATCH_START_UNSTAG',&
global_meta%sn_p_unstag_s,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'SOUTH-NORTH_PATCH_END_UNSTAG', &
global_meta%sn_p_unstag_e,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'SOUTH-NORTH_PATCH_START_STAG', &
global_meta%sn_p_stag_s,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'SOUTH-NORTH_PATCH_END_STAG', &
global_meta%sn_p_stag_e,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'BOTTOM-TOP_PATCH_START_UNSTAG',&
global_meta%bt_p_unstag_s,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'BOTTOM-TOP_PATCH_END_UNSTAG', &
global_meta%bt_p_unstag_e,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'BOTTOM-TOP_PATCH_START_STAG', &
global_meta%bt_p_stag_s,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'BOTTOM-TOP_PATCH_END_STAG', &
global_meta%bt_p_stag_e,istatus)
!WRFV2.1
CALL put_dom_ti_integer(nfid,io_form, 'GRID_ID', &
global_meta%grid_id,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'PARENT_ID', &
global_meta%parent_id,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'I_PARENT_START', &
global_meta%i_parent_start,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'J_PARENT_START', &
global_meta%j_parent_start,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'PARENT_GRID_RATIO', &
global_meta%parent_grid_ratio,istatus)
CALL put_dom_ti_real (nfid,io_form, 'DT',global_meta%dt,istatus)
CALL put_dom_ti_real (nfid,io_form, 'CEN_LAT', &
global_meta%cen_lat,istatus)
CALL put_dom_ti_real (nfid,io_form, 'CEN_LON', &
global_meta%cen_lon,istatus)
CALL put_dom_ti_real (nfid,io_form, 'TRUELAT1', &
global_meta%tru_lat1,istatus)
CALL put_dom_ti_real (nfid,io_form, 'TRUELAT2', &
global_meta%tru_lat2,istatus)
CALL put_dom_ti_real (nfid,io_form, 'MOAD_CEN_LAT', &
global_meta%moad_cen_lat,istatus)
CALL put_dom_ti_real (nfid,io_form, 'STAND_LON', &
global_meta%stand_lon,istatus)
IF (.NOT. bdyflg) THEN
CALL put_dom_ti_char(nfid,io_form,'SIMULATION_START_DATE',& !WRFV2.1
global_meta%start_date(1:19),istatus)
CALL put_dom_ti_real (nfid,io_form, 'GMT', &
global_meta%gmt,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'JULYR', &
global_meta%julyr,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'JULDAY', &
global_meta%julday,istatus)
END IF
CALL put_dom_ti_integer(nfid,io_form, 'MAP_PROJ', &
global_meta%map_proj,istatus)
CALL put_dom_ti_char(nfid,io_form,'MMINLU',global_meta%mminlu,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'ISWATER', &
global_meta%iswater,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'ISICE', &
global_meta%isice,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'ISURBAN', &
global_meta%isurban,istatus)
CALL put_dom_ti_integer(nfid,io_form, 'ISOILWATER', &
global_meta%isoilwater,istatus)
IF (io_form == 7) CALL exit_ncd_define(nfid,istatus)
RETURN
END SUBROUTINE write_global_attribute
SUBROUTINE put_dom_ti_char(nfid,io_form,attname,attstr,istatus) 10,2
IMPLICIT NONE
INTEGER, INTENT(IN) :: nfid
INTEGER, INTENT(IN) :: io_form
CHARACTER(*), INTENT(IN) :: attname
CHARACTER(*), INTENT(IN) :: attstr
INTEGER, INTENT(OUT):: istatus
INCLUDE 'mp.inc'
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Begin of executable code ... ...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
SELECT CASE (io_form)
CASE (1) ! binary
IF(myproc == 0) CALL ext_int_put_dom_ti_char(nfid,attname,attstr, &
iStatus )
CASE (5) ! PHDF5
CALL put_phdf5_dom_ti_char(nfid,attname,attstr,istatus)
CASE (7) ! NetCDF
IF(myproc == 0) CALL put_ncd_dom_ti_char(nfid,attname,attstr,istatus)
CASE DEFAULT
WRITE(0,*) 'ERROR: unsupport IO format: ',io_form
istatus = -1
END SELECT
RETURN
END SUBROUTINE put_dom_ti_char
SUBROUTINE put_dom_ti_integer(nfid,io_form,attname,attval,istatus) 52,2
IMPLICIT NONE
INTEGER, INTENT(IN) :: nfid
INTEGER, INTENT(IN) :: io_form
CHARACTER(*), INTENT(IN) :: attname
INTEGER, INTENT(IN) :: attval
INTEGER, INTENT(OUT) :: istatus
INCLUDE 'mp.inc'
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Begin of executable code ... ...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
SELECT CASE (io_form)
CASE (1) ! binary
IF(myproc == 0) CALL ext_int_put_dom_ti_integer(nfid,attname,attval,&
1,iStatus )
CASE (5) ! PHDF5
CALL put_phdf5_dom_ti_integer(nfid,attname,attval,istatus)
CASE (7) ! NetCDF
IF(myproc == 0) CALL put_ncd_dom_ti_integer(nfid,attname,attval,istatus)
CASE DEFAULT
WRITE(0,*) 'ERROR: unsupport IO format: ',io_form
istatus = -1
END SELECT
RETURN
END SUBROUTINE put_dom_ti_integer
SUBROUTINE put_dom_ti_real(nfid,io_form,attname,attval,istatus) 20,2
IMPLICIT NONE
INTEGER, INTENT(IN) :: nfid
INTEGER, INTENT(IN) :: io_form
CHARACTER(*), INTENT(IN) :: attname
REAL, INTENT(IN) :: attval
INTEGER, INTENT(OUT) :: istatus
INCLUDE 'mp.inc'
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Begin of executable code ... ...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
SELECT CASE (io_form)
CASE (1) ! binary
IF (myproc == 0) CALL ext_int_put_dom_ti_real(nfid,attname,attval, &
1,iStatus )
CASE (5) ! PHDF5
CALL put_phdf5_dom_ti_real(nfid,attname,attval,1,istatus)
CASE (7) ! NetCDF
IF (myproc == 0) CALL put_ncd_dom_ti_real(nfid,attname,attval, &
1,istatus)
CASE DEFAULT
WRITE(0,*) 'ERROR: unsupport IO format: ',io_form
istatus = -1
END SELECT
RETURN
END SUBROUTINE put_dom_ti_real
SUBROUTINE put_dom_ti_varreal(nfid,io_form,attname,attval,attsiz,istatus) 2,2
IMPLICIT NONE
INTEGER, INTENT(IN) :: nfid
INTEGER, INTENT(IN) :: io_form
CHARACTER(*), INTENT(IN) :: attname
INTEGER, INTENT(IN) :: attsiz
REAL, INTENT(IN) :: attval(attsiz)
INTEGER, INTENT(OUT) :: istatus
INCLUDE 'mp.inc'
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Begin of executable code ... ...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
SELECT CASE (io_form)
CASE (1) ! binary
IF (myproc == 0) CALL ext_int_put_dom_ti_real(nfid,attname,attval, &
attsiz,iStatus )
CASE (5) ! PHDF5
CALL put_phdf5_dom_ti_real(nfid,attname,attval,attsiz,istatus)
CASE (7) ! NetCDF
IF (myproc == 0) CALL put_ncd_dom_ti_real(nfid,attname,attval, &
attsiz,istatus)
CASE DEFAULT
WRITE(0,*) 'ERROR: unsupport IO format: ',io_form
istatus = -1
END SELECT
RETURN
END SUBROUTINE put_dom_ti_varreal
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE write_times_str ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE write_times_str(nfid,io_form,varname,currDate,DateStr,ntime) 5,2
!
!------------------------------------------------------------------
!
! PURPOSE:
!
!------------------------------------------------------------------
IMPLICIT NONE
INTEGER, INTENT(IN) :: nfid
INTEGER, INTENT(IN) :: io_form
CHARACTER(*), INTENT(IN) :: varname
CHARACTER(*), INTENT(IN) :: CurrDate
CHARACTER(*), INTENT(IN) :: DateStr
INTEGER, INTENT(IN) :: ntime
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: istatus
CHARACTER(120) :: tmpname, lowName
INTEGER, PARAMETER :: upper_to_lower =IACHAR('a')-IACHAR('A')
CHARACTER(1) :: c
INTEGER :: i,namelen
INCLUDE 'mp.inc'
!
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
SELECT CASE (io_form)
CASE (1) ! binary
IF (myproc == 0) CALL ext_int_put_dom_td_char(nfid,varname,CurrDate, &
DateStr,iStatus )
CASE (5) ! PHDF5
CALL put_phdf5_dom_td_char(nfid,varname,CurrDate,DateStr,istatus)
CASE (7) ! NetCDF
IF ( varname == 'Times' ) THEN
tmpname = varname
ELSE
namelen = LEN_TRIM(varName)
DO i=1,namelen
c = varName(i:i)
IF( 'A' <= c .AND. c <= 'Z') THEN
lowName(i:i) = ACHAR(IACHAR(c)+upper_to_lower)
ELSE IF( c == '-' .OR. c == ':') THEN
lowName(i:i) = '_'
ELSE
lowName(i:i) = c
END IF
END DO
tmpname = 'md___'//lowName(1:namelen)//'e_x_t_d_o_m_a_i_n_m_e_t_a_data_'
END IF
IF (myproc == 0) CALL put_ncd_dom_td_char(nfid,tmpname, &
DateStr,ntime,istatus)
CASE DEFAULT
WRITE(0,*) 'ERROR: unsupport IO format: ',io_form
istatus = -1
END SELECT
RETURN
END SUBROUTINE write_times_str
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE write1d ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE write1d(nout,io_form,var_meta,DateStr,var1d,nz,fzone) 65,3
!
!------------------------------------------------------------------
!
! PURPOSE:
!
! Write 1D vector to the output file.
!
!------------------------------------------------------------------
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: nout
INTEGER, INTENT(IN) :: io_form
TYPE(wrf_var_metadata), INTENT(IN) :: var_meta
CHARACTER(*), INTENT(IN) :: DateStr
INTEGER, INTENT(IN) :: nz
INTEGER, INTENT(IN) :: fzone
REAL, INTENT(IN) :: var1d(nz)
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: istatus
INCLUDE 'mp.inc'
CHARACTER(80) :: DimNames(3)
INTEGER :: DomainStart(3), DomainEnd(3)
INTEGER :: MemoryStart(3), MemoryEnd(3)
INTEGER :: PatchStart(3), PatchEnd(3)
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing 1D variable ', var_meta%name
DimNames(1) = var_meta%dimName1
DimNames(2) = var_meta%dimName2
DimNames(3) = var_meta%dimName3
DomainStart(:) = 1
DomainEnd(1) = nz
DomainEnd(2:3) = 1
MemoryStart(:) = 1
MemoryEnd(1) = nz
MemoryEnd(2:3) = 1
PatchStart(:) = 1
PatchEnd(1) = nz
PatchEnd(2:3) = 1
SELECT CASE (io_form)
CASE (1) ! binary
IF (myproc == 0) CALL ext_int_write_field( nout, DateStr, Var_meta%Name, &
var1d, var_meta%FieldType, 0, 0, 1, &
var_meta%MemoryOrder, var_meta%Stagger, DimNames, &
DomainStart, DomainEnd, MemoryStart, MemoryEnd, &
DomainStart, DomainEnd, iStatus )
CASE (5) ! PHDF5
CALL write_phdf5_field(nout,DateStr,var_meta%name,var_meta%description, &
var_meta%units,var_meta%stagger, &
var1d,var_meta%fieldType, 1, &
var_meta%memoryOrder,DimNames, &
DomainStart,DomainEnd, &
MemoryStart,MemoryEnd, &
PatchStart,PatchEnd, istatus)
CASE (7) ! NetCDF
IF (myproc == 0) CALL write_ncd_1d(nout,TRIM(var_meta%name), &
var1d,nz,istatus)
CASE DEFAULT
WRITE(0,*) 'ERROR: unsupport IO format: ',io_form
istatus = -1
END SELECT
IF (istatus == 0) THEN
WRITE(6,'(a)') ' ... DONE.'
ELSE
WRITE(6,'(a)') ' ... ERROR.'
END IF
RETURN
END SUBROUTINE write1d
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE write1di ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE write1di(nout,io_form,var_meta,DateStr,var1di,nz,fzone) 3,3
!
!------------------------------------------------------------------
!
! PURPOSE:
!
! Write 1D integer vector to the output file.
!
!------------------------------------------------------------------
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: nout
INTEGER, INTENT(IN) :: io_form
TYPE(wrf_var_metadata), INTENT(IN) :: var_meta
CHARACTER(*), INTENT(IN) :: DateStr
INTEGER, INTENT(IN) :: fzone
INTEGER, INTENT(IN) :: nz
INTEGER, INTENT(IN) :: var1di(nz)
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: istatus
INCLUDE 'mp.inc'
CHARACTER(80) :: DimNames(3)
INTEGER :: DomainStart(3), DomainEnd(3)
INTEGER :: MemoryStart(3), MemoryEnd(3)
INTEGER :: PatchStart(3), PatchEnd(3)
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
IF (myproc == 0) &
WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing 1D integer variable ', var_meta%name
DimNames(1) = var_meta%dimName1
DimNames(2) = var_meta%dimName2
DimNames(3) = var_meta%dimName3
DomainStart(:) = 1
DomainEnd(1) = nz
DomainEnd(2:3) = 1
MemoryStart(:) = 1
MemoryEnd(1) = nz
MemoryEnd(2:3) = 1
PatchStart(:) = 1
PatchEnd(1) = nz
PatchEnd(2:3) = 1
SELECT CASE (io_form)
CASE (1) ! binary
IF (myproc == 0) CALL ext_int_write_field( nout, DateStr, Var_meta%Name, &
var1di, var_meta%FieldType, 0, 0, 1, &
var_meta%MemoryOrder, var_meta%Stagger, DimNames, &
DomainStart, DomainEnd, MemoryStart, MemoryEnd, &
DomainStart, DomainEnd, iStatus )
CASE (5) ! PHDF5
CALL write_phdf5_field(nout,DateStr,var_meta%name,var_meta%description, &
var_meta%units,var_meta%stagger, &
var1di,var_meta%fieldType, 1, &
var_meta%memoryOrder,DimNames, &
DomainStart,DomainEnd, &
MemoryStart,MemoryEnd, &
PatchStart,PatchEnd, istatus)
CASE (7) ! NetCDF
IF (myproc == 0) CALL write_ncd_1di(nout,TRIM(var_meta%name), &
var1di,nz,istatus)
CASE DEFAULT
WRITE(0,*) 'ERROR: unsupport IO format: ',io_form
istatus = -1
END SELECT
IF (myproc == 0 .AND. istatus == 0) WRITE(6,'(a)') ' ... DONE.'
RETURN
END SUBROUTINE write1di
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE write2d ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE write2d(nout,io_form,var_meta,DateStr,var2d,nx,ny, & 64,3
fzone,temlg,nxlg,nylg)
!
!
!------------------------------------------------------------------
!
! PURPOSE:
!
! Write 2D array to the output file.
!
!------------------------------------------------------------------
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: nout
INTEGER, INTENT(IN) :: io_form
TYPE(wrf_var_metadata), INTENT(IN) :: var_meta
CHARACTER(*), INTENT(IN) :: DateStr
INTEGER, INTENT(IN) :: nx,ny
INTEGER, INTENT(IN) :: nxlg,nylg
INTEGER, INTENT(IN) :: fzone
REAL, INTENT(IN) :: var2d(nx,ny)
REAL, INTENT(IN) :: temlg(nxlg,nylg)
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: istatus
INCLUDE 'mp.inc'
CHARACTER(80) :: DimNames(3)
INTEGER :: DomainStart(3), DomainEnd(3)
INTEGER :: MemoryStart(3), MemoryEnd(3)
INTEGER :: PatchStart(3), PatchEnd(3)
INTEGER :: ilocs,iloce,jlocs,jloce
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
IF (myproc == 0) &
WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing 2D variable ', var_meta%name
DimNames(1) = var_meta%dimName1
DimNames(2) = var_meta%dimName2
DimNames(3) = var_meta%dimName3
DomainStart(:) = 1
DomainEnd(1) = nxlg
DomainEnd(2) = nylg
DomainEnd(3) = 1 ! 2d special
IF (io_form == 5) THEN ! No merge
ilocs = (nx-fzone)*(loc_x-1)+fzone
jlocs = (ny-fzone)*(loc_y-1)+fzone
iloce = (nx-fzone)*(loc_x)+fzone
jloce = (ny-fzone)*(loc_y)+fzone
MemoryStart(1) = ilocs
MemoryStart(2) = jlocs
MemoryStart(3) = 1
MemoryEnd(1) = iloce
MemoryEnd(2) = jloce
MemoryEnd(3) = 1 ! 2d special
PatchStart(1) = ilocs
PatchEnd(1) = iloce - fzone
IF (var_meta%stagger == 'X') THEN
IF (loc_x > 1) PatchStart(1) = ilocs + fzone
PatchEnd(1) = iloce
END IF
PatchStart(2) = jlocs
PatchEnd(2) = jloce - fzone
IF (var_meta%stagger == 'Y') THEN
IF (loc_y > 1 ) PatchStart(2) = jlocs + fzone
PatchEnd(2) = jloce
END IF
PatchStart(3) = 1
PatchEnd(3) = 1 ! 2d special
CALL write_phdf5_field(nout,DateStr,var_meta%name,var_meta%description, &
var_meta%units,var_meta%stagger, &
var2d,var_meta%fieldType, 1, &
var_meta%memoryOrder,DimNames, &
DomainStart,DomainEnd, &
MemoryStart,MemoryEnd, &
PatchStart,PatchEnd, istatus)
ELSE ! Need merge
IF (var_meta%stagger == 'X') THEN
CALL wrf_merge2du(var2d,nx,ny,fzone,temlg)
ELSE IF (var_meta%stagger == 'Y') THEN
CALL wrf_merge2dv(var2d,nx,ny,fzone,temlg)
ELSE
CALL wrf_merge2dt(var2d,nx,ny,fzone,temlg)
END IF
IF (io_form == 1) THEN ! Binary
IF (myproc == 0) CALL ext_int_write_field( nout, DateStr, &
Var_meta%Name, temlg, var_meta%FieldType, 0, 0, 1, &
var_meta%MemoryOrder, var_meta%Stagger, DimNames, &
DomainStart, DomainEnd, DomainStart, DomainEnd, &
DomainStart, DomainEnd, iStatus )
! temlg contain domain data, so Domain, Memeory &
! Patch index are the same
ELSE IF (io_form == 7) THEN ! NetCDF
IF (myproc == 0) CALL write_ncd_2d(nout,TRIM(var_meta%name), &
temlg,nxlg,nylg,istatus)
ELSE
WRITE(0,*) 'ERROR: unsupport IO format: ',io_form
istatus = -1
END IF
END IF
IF (myproc == 0 .AND. istatus == 0) WRITE(6,'(a)') ' ... DONE.'
RETURN
END SUBROUTINE write2d
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE write2di ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE write2di(nout,io_form,var_meta,DateStr,var2di,nx,ny, & 4,3
fzone,temlg,nxlg,nylg)
!
!------------------------------------------------------------------
!
! PURPOSE:
!
! Write 2D array to the output file.
!
!------------------------------------------------------------------
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: nout
INTEGER, INTENT(IN) :: io_form
TYPE(wrf_var_metadata), INTENT(IN) :: var_meta
CHARACTER(*), INTENT(IN) :: DateStr
INTEGER, INTENT(IN) :: nx,ny
INTEGER, INTENT(IN) :: nxlg,nylg
INTEGER, INTENT(IN) :: fzone
INTEGER, INTENT(IN) :: var2di(nx,ny)
INTEGER, INTENT(IN) :: temlg(nxlg,nylg)
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: istatus
INCLUDE 'mp.inc'
CHARACTER(80) :: DimNames(3)
INTEGER :: DomainStart(3), DomainEnd(3)
INTEGER :: MemoryStart(3), MemoryEnd(3)
INTEGER :: PatchStart(3), PatchEnd(3)
INTEGER :: ilocs,iloce,jlocs,jloce
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
IF (myproc == 0) &
WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing 2D integer variable ', var_meta%name
DimNames(1) = var_meta%dimName1
DimNames(2) = var_meta%dimName2
DimNames(3) = var_meta%dimName3
DomainStart(:) = 1
DomainEnd(1) = nxlg
DomainEnd(2) = nylg
DomainEnd(3) = 1 ! 2d special
IF (io_form == 5) THEN ! No merge
ilocs = (nx-fzone)*(loc_x-1)+fzone
jlocs = (ny-fzone)*(loc_y-1)+fzone
iloce = (nx-fzone)*(loc_x)+fzone
jloce = (ny-fzone)*(loc_y)+fzone
MemoryStart(1) = ilocs
MemoryStart(2) = jlocs
MemoryStart(3) = 1
MemoryEnd(1) = iloce
MemoryEnd(2) = jloce
MemoryEnd(3) = 1
PatchStart(1) = ilocs
PatchEnd(1) = iloce - fzone
IF (var_meta%stagger == 'X') THEN
IF (loc_x > 1) PatchStart(1) = ilocs + fzone
PatchEnd(1) = iloce
END IF
PatchStart(2) = jlocs
PatchEnd(2) = jloce - fzone
IF (var_meta%stagger == 'Y') THEN
IF (loc_y > 1 ) PatchStart(2) = jlocs + fzone
PatchEnd(2) = jloce
END IF
PatchStart(3) = 1
PatchEnd(3) = 1 ! 2d special
CALL write_phdf5_field(nout,DateStr,var_meta%name,var_meta%description, &
var_meta%units,var_meta%stagger, &
var2di,var_meta%fieldType, 1, &
var_meta%memoryOrder,DimNames, &
DomainStart,DomainEnd, &
MemoryStart,MemoryEnd, &
PatchStart,PatchEnd, istatus)
ELSE ! Need merge
IF (var_meta%stagger == 'X') THEN
WRITE(0,*) 'WARNING: Need to implement merger for integer 2D variable.'
ELSE IF (var_meta%stagger == 'Y') THEN
WRITE(0,*) 'WARNING: Need to implement merger for integer 2D variable.'
ELSE
CALL wrf_merge2di(var2di,nx,ny,fzone,temlg)
END IF
IF (io_form == 1) THEN ! Binary
IF (myproc == 0) CALL ext_int_write_field( nout, DateStr, &
Var_meta%Name, temlg, var_meta%FieldType, 0, 0, 1, &
var_meta%MemoryOrder, var_meta%Stagger, DimNames, &
DomainStart, DomainEnd, DomainStart, DomainEnd, &
DomainStart, DomainEnd, iStatus )
! temlg contain domain data, so Domain, Memeory &
! Patch index are the same
ELSE IF (io_form == 7) THEN ! NetCDF
IF (myproc == 0) CALL write_ncd_2di(nout,TRIM(var_meta%name), &
temlg,nxlg,nylg,istatus)
ELSE
WRITE(0,*) 'ERROR: unsupport IO format: ',io_form
istatus = -1
END IF
END IF
IF (myproc == 0 .AND. istatus == 0) WRITE(6,'(a)') ' ... DONE.'
RETURN
END SUBROUTINE write2di
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE write3d ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE write3d(nout,io_form,var_meta,DateStr,var3d,nx,ny,nz, & 21,3
fzone,temlg,temxzylg,nxlg,nylg,nzlg)
!
!------------------------------------------------------------------
!
! PURPOSE:
!
! Write 3D array to the output file.
!
!------------------------------------------------------------------
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: nout
INTEGER, INTENT(IN) :: io_form
TYPE(wrf_var_metadata), INTENT(IN) :: var_meta
CHARACTER(*), INTENT(IN) :: DateStr
INTEGER, INTENT(IN) :: nx,ny,nz
INTEGER, INTENT(IN) :: nxlg,nylg,nzlg
INTEGER, INTENT(IN) :: fzone
REAL, INTENT(IN) :: var3d(nx,ny,nz)
REAL, INTENT(OUT) :: temlg(nxlg,nylg,nzlg)
REAL, INTENT(OUT) :: temxzylg(nxlg,nzlg,nylg)
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: istatus
INCLUDE 'mp.inc'
CHARACTER(80) :: DimNames(3)
INTEGER :: DomainStart(3), DomainEnd(3)
INTEGER :: MemoryStart(3), MemoryEnd(3)
INTEGER :: PatchStart(3), PatchEnd(3)
INTEGER :: ilocs,iloce,jlocs,jloce
INTEGER :: i, j, k
CHARACTER(3) :: MemOrder
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
IF(myproc == 0) &
WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing 3D variable ', var_meta%name
IF (io_form == 5) THEN ! No merge
DimNames(1) = var_meta%dimName1
DimNames(2) = var_meta%dimName2
DimNames(3) = var_meta%dimName3
DomainStart(1) = 1
DomainStart(2) = 1
DomainStart(3) = 1
DomainEnd(1) = nxlg
DomainEnd(2) = nylg
DomainEnd(3) = nzlg
ilocs = (nx-fzone)*(loc_x-1)+fzone
jlocs = (ny-fzone)*(loc_y-1)+fzone
iloce = (nx-fzone)*(loc_x)+fzone
jloce = (ny-fzone)*(loc_y)+fzone
MemoryStart(1) = ilocs
MemoryStart(2) = jlocs
MemoryStart(3) = 1
MemoryEnd(1) = iloce
MemoryEnd(2) = jloce
MemoryEnd(3) = nz
PatchStart(1) = ilocs
PatchEnd(1) = iloce - fzone
IF (var_meta%stagger == 'X') THEN
IF (loc_x > 1) PatchStart(1) = ilocs + fzone
PatchEnd(1) = iloce
END IF
PatchStart(2) = jlocs
PatchEnd(2) = jloce - fzone
IF (var_meta%stagger == 'Y') THEN
IF (loc_y > 1 ) PatchStart(2) = jlocs + fzone
PatchEnd(2) = jloce
END IF
PatchStart(3) = 1
PatchEnd(3) = nzlg
CALL write_phdf5_field(nout,DateStr,var_meta%name,var_meta%description, &
var_meta%units,var_meta%stagger, &
var3d,var_meta%fieldType, 1, &
var_meta%memoryOrder,DimNames, &
DomainStart,DomainEnd, &
MemoryStart,MemoryEnd, &
PatchStart,PatchEnd, istatus)
ELSE ! Need merge
IF (var_meta%stagger == 'X') THEN
CALL wrf_merge3du(var3d,nx,ny,nz,fzone,temlg)
ELSE IF (var_meta%stagger == 'Y') THEN
CALL wrf_merge3dv(var3d,nx,ny,nz,fzone,temlg)
ELSE IF (var_meta%stagger == 'Z') THEN
CALL wrf_merge3dw(var3d,nx,ny,nz,fzone,temlg)
ELSE
CALL wrf_merge3dt(var3d,nx,ny,nz,fzone,temlg)
END IF
IF (io_form == 1) THEN ! Binary
MemOrder = 'XZY'
DimNames(1) = var_meta%dimName1 ! X
DimNames(2) = var_meta%dimName3 ! Z
DimNames(3) = var_meta%dimName2 ! Y
DomainStart(1) = 1
DomainStart(2) = 1
DomainStart(3) = 1
DomainEnd(1) = nxlg
DomainEnd(2) = nzlg
DomainEnd(3) = nylg
DO k = 1,nzlg
DO j = 1,nylg
DO i = 1,nxlg
temxzylg(i,k,j) = temlg(i,j,k)
END DO
END DO
END DO
IF (myproc == 0) CALL ext_int_write_field( nout, DateStr, &
Var_meta%Name, temxzylg, var_meta%FieldType, 0, 0, 1, &
MemOrder, var_meta%Stagger, DimNames, &
DomainStart, DomainEnd, DomainStart, DomainEnd, &
DomainStart, DomainEnd, iStatus )
! temlg contain domain data, so Domain, Memeory &
! Patch index are the same
ELSE IF (io_form == 7) THEN ! NetCDF
IF (myproc == 0) CALL write_ncd_3d(nout,TRIM(var_meta%name), &
temlg,nxlg,nylg,nzlg,istatus)
ELSE
WRITE(0,*) 'ERROR: unsupport IO format: ',io_form
istatus = -1
END IF
END IF
IF (myproc == 0 .AND. istatus == 0) WRITE(6,'(a)') ' ... DONE.'
RETURN
END SUBROUTINE write3d
!
!//////////////////////////////////////////////////////////////////
!
! Read WRF static file
!
!//////////////////////////////////////////////////////////////////
!
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE open_static_file ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE open_static_file(filename,ncid) 2
!
!------------------------------------------------------------------
!
! PURPOSE:
!
! Open the static file for read
!
!------------------------------------------------------------------
IMPLICIT NONE
CHARACTER(LEN=*), INTENT(IN) :: filename
INTEGER, INTENT(OUT) :: ncid
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: istatus
LOGICAL :: static_exists
INCLUDE 'netcdf.inc'
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
INQUIRE(FILE=filename, EXIST=static_exists)
IF (static_exists) THEN
istatus = NF_OPEN(TRIM(filename),NF_NOWRITE,ncid)
CALL nf_handle_error(istatus,'NF_OPEN')
ELSE
PRINT '(A)', 'Static file not found: ', filename
STOP 'open_wrfsi_static'
ENDIF
RETURN
END SUBROUTINE open_static_file
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE close_static_file ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE close_static_file(ncid) 2
!
!------------------------------------------------------------------
!
! PURPOSE:
!
! Close the static file.
!
!------------------------------------------------------------------
IMPLICIT NONE
INTEGER, INTENT(IN) :: ncid
INCLUDE 'netcdf.inc'
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
!
INTEGER :: istatus
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
istatus = NF_CLOSE(ncid)
CALL nf_handle_error(istatus,'NF_CLOSE')
RETURN
END SUBROUTINE close_static_file
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE check_static_grid ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE check_static_grid(staticopt,ncid,nxin,nyin,dxin,dyin, & 2
mapprojin,trulat1in,trulat2in,trulonin,ISSAME)
!
!------------------------------------------------------------------
!
! PURPOSE:
!
! Read the grid information from the static NetCDF file, and
! Check whether it is at the same grid as the input map projection.
!
!------------------------------------------------------------------
IMPLICIT NONE
INTEGER, INTENT(IN) :: staticopt ! 0: WRFSI static file
! 1: WRF static file
INTEGER, INTENT(IN) :: ncid
INTEGER, INTENT(IN) :: nxin,nyin
REAL, INTENT(IN) :: dxin,dyin
INTEGER, INTENT(IN) :: mapprojin
REAL, INTENT(IN) :: trulat1in,trulat2in
REAL, INTENT(IN) :: trulonin
LOGICAL, INTENT(OUT) :: ISSAME
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: nx, ny, iproj
INTEGER :: nxlg, nylg
REAL :: dx, dy
REAL :: trulat1,trulat2,trulon
REAL :: lat1,lon1
INTEGER :: mapproj
REAL, PARAMETER :: eps = 0.00001
INTEGER :: istatus, vid
CHARACTER(LEN=132) :: grid_type
INCLUDE 'netcdf.inc'
INCLUDE 'mp.inc'
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
IF (staticopt == 0) THEN
istatus = NF_INQ_VARID(ncid, 'Nx', vid)
CALL nf_handle_error(istatus,'get_static_grid, Nx')
istatus = NF_GET_VAR_INT(ncid,vid,nx)
CALL nf_handle_error(istatus,'get_static_grid, Nx')
istatus = NF_INQ_VARID(ncid, 'Ny', vid)
CALL nf_handle_error(istatus,'get_static_grid, NF_INQ_VARID')
istatus = NF_GET_VAR_INT(ncid,vid,ny)
CALL nf_handle_error(istatus,'get_static_grid, NF_GET_VAR_INT')
istatus = NF_INQ_VARID(ncid, 'Dx', vid)
CALL nf_handle_error(istatus,'get_static_grid, NF_INQ_VARID')
istatus = NF_GET_VAR_REAL(ncid,vid,dx)
CALL nf_handle_error(istatus,'get_static_grid, NF_GET_VAR_REAL')
istatus = NF_INQ_VARID(ncid, 'Dy', vid)
CALL nf_handle_error(istatus,'NF_INQ_VARID')
istatus = NF_GET_VAR_REAL(ncid,vid,dy)
CALL nf_handle_error(istatus,'NF_GET_VAR_REAL')
istatus = NF_INQ_VARID(ncid, 'La1', vid)
CALL nf_handle_error(istatus,'NF_INQ_VARID')
istatus = NF_GET_VAR_REAL(ncid,vid,lat1)
CALL nf_handle_error(istatus,'NF_GET_VAR_REAL')
istatus = NF_INQ_VARID(ncid, 'Lo1', vid)
CALL nf_handle_error(istatus,'NF_INQ_VARID')
istatus = NF_GET_VAR_REAL(ncid,vid,lon1)
CALL nf_handle_error(istatus,'NF_GET_VAR_REAL')
IF(lon1 > 180) lon1 = lon1 - 360
istatus = NF_INQ_VARID(ncid, 'LoV', vid)
CALL nf_handle_error(istatus,'NF_INQ_VARID')
istatus = NF_GET_VAR_REAL(ncid,vid,trulon)
CALL nf_handle_error(istatus,'NF_GET_VAR_REAL')
IF(trulon > 180) trulon = trulon - 360
istatus = NF_INQ_VARID(ncid, 'Latin1', vid)
CALL nf_handle_error(istatus,'NF_INQ_VARID')
istatus = NF_GET_VAR_REAL(ncid,vid,trulat1)
CALL nf_handle_error(istatus,'NF_GET_VAR_REAL')
istatus = NF_INQ_VARID(ncid, 'Latin2', vid)
CALL nf_handle_error(istatus,'NF_INQ_VARID')
istatus = NF_GET_VAR_REAL(ncid,vid,trulat2)
CALL nf_handle_error(istatus,'NF_GET_VAR_REAL')
istatus = NF_INQ_VARID(ncid, 'grid_type', vid)
CALL nf_handle_error(istatus,'NF_INQ_VARID')
istatus = NF_GET_VAR_TEXT(ncid,vid,grid_type)
CALL nf_handle_error(istatus,'NF_GET_VAR_REAL')
IF( INDEX(grid_type,'polar') > 0 ) mapproj = 1
IF( INDEX(grid_type,'lambert conformal') > 0 ) mapproj = 2
IF( INDEX(grid_type,'mercator') > 0 ) mapproj = 3
ELSE IF (staticopt == 1) THEN ! WRF static file
istatus = NF_GET_ATT_INT(ncid,NF_GLOBAL,'WEST-EAST_GRID_DIMENSION', nx)
CALL nf_handle_error(istatus,'get_static_grid, WEST-EAST_GRID_DIMENSION.')
istatus = NF_GET_ATT_INT(ncid,NF_GLOBAL,'SOUTH-NORTH_GRID_DIMENSION',ny)
CALL nf_handle_error(istatus,'get_static_grid, SOUTH-NORTH_GRID_DIMENSION.')
istatus = NF_GET_ATT_REAL(ncid,NF_GLOBAL,'DX', dx)
CALL nf_handle_error(istatus,'get_static_grid, DX.')
istatus = NF_GET_ATT_REAL(ncid,NF_GLOBAL,'DY', dy)
CALL nf_handle_error(istatus,'get_static_grid, DY.')
istatus = NF_GET_ATT_REAL(ncid,NF_GLOBAL,'TRUELAT1', trulat1)
CALL nf_handle_error(istatus,'get_static_grid, TRUELAT1.')
istatus = NF_GET_ATT_REAL(ncid,NF_GLOBAL,'TRUELAT2', trulat2)
CALL nf_handle_error(istatus,'get_static_grid, TRUELAT2.')
istatus = NF_GET_ATT_REAL(ncid,NF_GLOBAL,'STAND_LON', trulon)
CALL nf_handle_error(istatus,'get_static_grid, STAND_LON.')
IF(trulon > 180) trulon = trulon - 360
istatus = NF_GET_ATT_INT(ncid,NF_GLOBAL,'MAP_PROJ', iproj)
CALL nf_handle_error(istatus,'get_static_grid, MAP_PROJ.')
IF(iproj == 0) THEN ! No projection
mapproj = 0
ELSE IF(iproj == 1) THEN ! LAMBERT CONFORMAL
mapproj = 2
ELSE IF(iproj == 2) THEN ! POLAR STEREOGRAPHIC
mapproj = 1
ELSE IF(iproj == 3) THEN ! MERCATOR
mapproj = 3
ELSE
WRITE(6,*) 'Unknown map projection, ', iproj
issame = .FALSE.
RETURN
END IF
ELSE
WRITE(6,'(a)') &
'Wrong staticopt (0 for WRFSI static file, 1 for WRF static file).'
issame = .FALSE.
RETURN
END IF
! Determine whether we are at the same grid with the static file
nxlg = (nxin - 1)*nproc_x + 1
nylg = (nyin - 1)*nproc_y + 1
issame = .TRUE.
IF(nxlg /= nx .OR. nylg /= ny .OR. &
ABS(dxin-dy) > eps .OR. ABS(dyin-dy) > eps .OR. &
ABS(mapprojin) /= mapproj .OR. &
ABS(trulonin-trulon) > eps .OR. &
ABS(trulat1in-trulat1)> eps .OR. &
ABS(trulat2in-trulat2)> eps ) THEN
WRITE(6,*) 'Grid info. from static file', ' WRF grid'
WRITE(6,*) ' =================', ' ========'
WRITE(6,'(4x,a,I7, 9x, I7)') 'nx: ',nx,nxlg
WRITE(6,'(4x,a,I7, 9x, I7)') 'ny: ',ny,nylg
WRITE(6,'(4x,a,F7.0,9x, F7.0)') 'dx: ',dx,dxin
WRITE(6,'(4x,a,F7.0,9x, F7.0)') 'dy: ',dy,dyin
WRITE(6,'(4x,a,I7, 5x,a,I7)') 'mapproj: ',mapproj, &
' ',mapprojin
WRITE(6,'(4x,a,F7.2,5x,a,F7.2)') 'trulat1: ',trulat1, &
' ',trulat1in
WRITE(6,'(4x,a,F7.2,5x,a,F7.2)') 'trulat2: ',trulat2, &
' ',trulat2in
WRITE(6,'(4x,a,F7.2,5x,a,F7.2)') 'trulon: ',trulon, &
' ',trulonin
WRITE(6,'(4x,a,F7.2,5x,a,F7.2)') 'SW corner lat.: ',lat1
WRITE(6,'(4x,a,F7.2,5x,a,F7.2)') 'SW corner lon.: ',lon1
WRITE(6,*) 'ERROR: Static NetCDF file is not at the same grid', &
' as WRF grid.'
WRITE(6,*) ' Program will stop for error.'
issame = .FALSE.
END IF
RETURN
END SUBROUTINE check_static_grid
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE get_static_landusef ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE get_static_landusef(ncid, var3d) 1,1
! Reads the individual 2D categorical landuse fraction arrays from
! the static file and populates the 3D variable.
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: ncid
REAL, INTENT(OUT) :: var3d(:,:,:)
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: cat
CHARACTER(LEN=3) :: varname
INTEGER :: varid
INTEGER :: istatus
REAL :: fillValue
INCLUDE 'netcdf.inc'
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! For now, we only support 16-category WMO/FAO data set, so hard code the
! info
! PRINT '(A)', 'Attempting to read categorical landuse fractions...'
DO cat = 1, LanduseCategories
WRITE(varname,'("u",I2.2)') cat
istatus = NF_INQ_VARID(ncid, varname, varid)
istatus = NF_GET_VAR_REAL(ncid,varid,var3d(:,:,cat))
CALL nf_handle_error(istatus,'NF_GET_VAR_REAL')
! istatus = NF_GET_ATT_REAL(ncid,varid,'_FillVale',fillValue)
! WHERE(var3d(:,:,cat) >= fillValue) var3d(:,:,cat) = rmissing
ENDDO
RETURN
END SUBROUTINE get_static_landusef
!
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE get_static_soil ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE get_static_soil(ncid,static_soiltop,static_soilbot) 1,1
! Reads the 2-layer soil categorical fractions and populates the arrays
! static_soiltop and static_soilbot
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: ncid
INTEGER, INTENT(OUT) :: static_soiltop(:,:,:)
INTEGER, INTENT(OUT) :: static_soilbot(:,:,:)
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: vid,istatus
INTEGER :: cat
CHARACTER(LEN=3) :: vname
REAL :: fillValue
INCLUDE 'netcdf.inc'
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! For now, we only support 16-category WMO/FAO data set, so hard code the
! info
! PRINT '(A)', 'Attempting to read categorical soil type fractions...'
DO cat = 1, SoilCategories
WRITE(vname,'("b",I2.2)') cat
istatus = NF_INQ_VARID(ncid, vname, vid)
istatus = NF_GET_VAR_REAL(ncid,vid,static_soilbot(:,:,cat))
CALL nf_handle_error(istatus,'get_soilbot')
! istatus = NF_GET_ATT_REAL(ncid,vid,'_FillVale',fillValue)
! WHERE(static_soilbot(:,:,cat) >= fillValue) static_soilbot(:,:,cat) = rmissing
WRITE(vname,'("t",I2.2)') cat
istatus = NF_INQ_VARID(ncid, vname, vid)
istatus = NF_GET_VAR_REAL(ncid,vid,static_soiltop(:,:,cat))
CALL nf_handle_error(istatus,'get_soiltop')
! istatus = NF_GET_ATT_REAL(ncid,vid,'_FillVale',fillValue)
! WHERE(static_soiltop(:,:,cat) >= fillValue) static_soiltop(:,:,cat) = rmissing
END DO
RETURN
END SUBROUTINE get_static_soil
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE get_static_monthly ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE get_static_monthly(staticopt, ncid, vartype, valid_day, & 4,3
var2d, varin3d, istatus)
! Returns a time-interpolated (valid for time) 2D array for either
! greenness ("g") or albedo ("a"), based on user-supplied type character.
! The monthly values are
! valid on the 15th day of each month. This routine only interpolates to the
! nearest day and does not account for leap years, but this should not be any
! big deal.
IMPLICIT NONE
INTEGER, INTENT(IN) :: staticopt
INTEGER, INTENT(IN) :: ncid
INTEGER, INTENT(IN) :: valid_day ! julday of the year
CHARACTER(LEN=1), INTENT(IN) :: vartype
REAL, INTENT(OUT) :: var2d(:,:)
REAL, INTENT(IN) :: varin3d(:,:,:)
INTEGER, INTENT(OUT) :: istatus
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: m, d1, d2, m1, m2
INTEGER :: nx,ny
CHARACTER(LEN=3) :: varname
REAL, ALLOCATABLE :: data1(:,:), data2(:,:)
REAL :: w1, w2
INTEGER :: i, j
INTEGER :: midmonth_day(12)
! midmonth_day is the julian day of the year corresponding to the 15th day
! of each month for a standard (non-leap) year
DATA midmonth_day / 15, 43, 74, 105, 135, 166, 196, 227, 258, 288, 319, 349 /
INTEGER :: dimid
INCLUDE 'netcdf.inc'
INTERFACE
SUBROUTINE get_static_2d(ncid,varname,var2d)
INTEGER, INTENT(IN) :: ncid
CHARACTER(LEN=3), INTENT(IN) :: varname
REAL, INTENT(OUT) :: var2d(:,:)
END SUBROUTINE get_static_2d
END INTERFACE
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
IF (staticopt == 0) THEN ! WRFSI data
! get the dimensions of data arrays
istatus = NF_INQ_DIMID(ncid,'x',dimid)
CALL nf_handle_error(istatus,'NF_INQ_DIMID')
istatus = NF_INQ_DIMLEN(ncid,dimid,nx)
CALL nf_handle_error(istatus,'NF_INQ_DIMLEN')
istatus = NF_INQ_DIMID(ncid,'y',dimid)
CALL nf_handle_error(istatus,'NF_INQ_DIMID')
istatus = NF_INQ_DIMLEN(ncid,dimid,ny)
CALL nf_handle_error(istatus,'NF_INQ_DIMLEN')
ELSE if (staticopt == 1) THEN ! WRF static data
istatus = NF_INQ_DIMID(ncid,'west_east_stag',dimid)
CALL nf_handle_error(istatus,'NF_INQ_DIMID')
istatus = NF_INQ_DIMLEN(ncid,dimid,nx)
CALL nf_handle_error(istatus,'NF_INQ_DIMLEN')
istatus = NF_INQ_DIMID(ncid,'south_north_stag',dimid)
CALL nf_handle_error(istatus,'NF_INQ_DIMID')
istatus = NF_INQ_DIMLEN(ncid,dimid,ny)
CALL nf_handle_error(istatus,'NF_INQ_DIMLEN')
ELSE
WRITE(6,*) 'Unknown staticopt in get_static_monthly.'
istatus = -1
RETURN
END IF
! Check data type character to make sure it is either greenness or albedo.
IF ((vartype /= "a").AND.(vartype /= "g")) THEN
PRINT *, 'Unknown data type character passed into get_wrfsi_static_monthly:', &
vartype
PRINT *,'Current supported values are a (albedo) and g (greenness fraction).'
STOP 'get_static_monthly'
ELSE IF (vartype == 'a') THEN
PRINT *, ' Getting time-interpolated albedo.'
ELSE IF (vartype == 'g') THEN
PRINT *, ' Getting time-interpolated greenness.'
END IF
!PRINT *, 'Time-interpolating to day # ', valid_day
! Find bounding months
IF ((valid_day < midmonth_day(1)) .OR. (valid_day > midmonth_day(12))) THEN
! December and January are bounding months
d1 = midmonth_day(12)
d2 = midmonth_day(1)
m1 = 12
m2 = 1
ELSE
find_bounds: DO m = 1, 11
d1 = midmonth_day(m)
d2 = midmonth_day(m+1)
IF (valid_day == d1) THEN
d2 = d1
m1 = m
m2 = m1
EXIT find_bounds
ELSE IF (valid_day == d2) THEN
d1 = d2
m1 = m + 1
m2 = m1
EXIT find_bounds
ELSE IF ((valid_day > d1).AND.(valid_day < d2)) THEN
m1 = m
m2 = m + 1
EXIT find_bounds
ENDIF
END DO find_bounds
END IF
! If d1 = d2, then we don't need any interpolation, just get that month's
! data values
IF ( d1 == d2) THEN
IF (staticopt == 0) THEN
WRITE(varname, '(A1,I2.2)') vartype,m1
CALL get_static_2d(ncid,varname,var2d)
ELSE ! staticopt == 1
DO j = 1,ny
DO i = 1,nx
var2d(i,j) = varin3d(i,j,m1)
END DO
END DO
END IF
ELSE
ALLOCATE(data1 (nx,ny))
ALLOCATE(data2 (nx,ny))
! We need to get the two months of bounding data and time interpolate
IF (staticopt == 0) THEN ! WRFSI data
WRITE(varname, '(A1,I2.2)') vartype,m1
CALL get_static_2d(ncid,varname,data1)
WRITE(varname, '(A1,I2.2)') vartype,m2
CALL get_static_2d(ncid,varname,data2)
ELSE ! WRF static data
data1(:,:) = varin3d(:,:,m1)
data2(:,:) = varin3d(:,:,m2)
END IF
! Compute weights
IF (d2 > d1) THEN
w1 = ( FLOAT(d2) - FLOAT(valid_day) ) / FLOAT(d2-d1)
ELSE ! We must be between Dec 15 and Jan 15
IF (valid_day < midmonth_day(1)) THEN ! We are in January
w1 = ( FLOAT(d2) - FLOAT(valid_day) ) / 31.
ELSE ! We are in December
w1 = ( 366. - FLOAT(valid_day) + FLOAT(midmonth_day(1)) ) / 31.
END IF
END IF
w2 = 1. - w1
DO j = 1,ny
DO i = 1,nx
var2d(i,j) = w1*data1(i,j) + w2*data2(i,j)
END DO
END DO
! WRITE(6,*) '**** ',w1,w2,data1(1,1),data2(1,1),var2d(1,1)
! StOP
DEALLOCATE(data1)
DEALLOCATE(data2)
END IF
istatus = 0
!WRITE(6,*) 'Returning from get_static_monthly'
RETURN
END SUBROUTINE get_static_monthly
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE get_static_2d ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE get_static_2d(ncid,varname, var2d) 8,1
! Subroutine to get the 2D field from the WRFSI static
! file
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: ncid
CHARACTER(LEN=3), INTENT(IN) :: varname
REAL, INTENT(OUT) :: var2d(:,:)
INCLUDE 'netcdf.inc'
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: istatus,vid
REAL :: fillValue
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
istatus = NF_INQ_VARID(ncid, varname, vid)
CALL nf_handle_error(istatus,'NF_INQ_VARID')
istatus = NF_GET_VAR_REAL(ncid,vid,var2d)
CALL nf_handle_error(istatus,'NF_GET_VAR_REAL')
! istatus = NF_GET_ATT_REAL(ncid,vid,'_FillVale',fillValue)
! WHERE(var2d >= fillValue) var2d = rmissing
RETURN
END SUBROUTINE get_static_2d
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE writebdy ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE writebdy(nout,io_form,DateStr,itime,varname,stagger,desc, & 24,6
bdyw,bdye,bdys,bdyn,nx,ny,nz,bdywidth, &
fzone,dbdyw,dbdye,dbdys,dbdyn, &
nxlg,nylg,nzlg,tem1,tem2)
!
!------------------------------------------------------------------
!
! PURPOSE:
!
! Write the 4 lateral boudnary arrays
!
!------------------------------------------------------------------
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: nout
INTEGER, INTENT(IN) :: io_form
CHARACTER(LEN=*), INTENT(IN) :: DateStr
INTEGER, INTENT(IN) :: itime
CHARACTER(LEN=*), INTENT(IN) :: varname
CHARACTER(LEN=*), INTENT(IN) :: stagger
CHARACTER(LEN=*), INTENT(IN) :: desc
INTEGER, INTENT(IN) :: nx,ny,nz,bdywidth
INTEGER, INTENT(IN) :: fzone
REAL, INTENT(INOUT) :: bdys(nx,nz,bdywidth)
REAL, INTENT(INOUT) :: bdyn(nx,nz,bdywidth)
REAL, INTENT(INOUT) :: bdyw(ny,nz,bdywidth)
REAL, INTENT(INOUT) :: bdye(ny,nz,bdywidth)
INTEGER, INTENT(IN) :: nxlg,nylg,nzlg
REAL, INTENT(IN) :: dbdys(nxlg,nzlg,bdywidth)
REAL, INTENT(IN) :: dbdyn(nxlg,nzlg,bdywidth)
REAL, INTENT(IN) :: dbdyw(nylg,nzlg,bdywidth)
REAL, INTENT(IN) :: dbdye(nylg,nzlg,bdywidth)
REAL, INTENT(OUT) :: tem1(nx,nz,bdywidth)
REAL, INTENT(OUT) :: tem2(ny,nz,bdywidth)
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: istatus
INCLUDE 'mp.inc'
CHARACTER(80) :: DimNames(3)
INTEGER :: DomainStart(3), DomainEnd(3)
INTEGER :: MemoryStart(3), MemoryEnd(3)
INTEGER :: PatchStart(3), PatchEnd(3)
INTEGER :: ilocs,iloce,jlocs,jloce
LOGICAL :: IOFlag
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
DimNames(2) = 'bottom_top'
DimNames(3) = 'bdy_width'
DomainStart(2) = 1
MemoryStart(2) = 1
PatchStart(2) = 1
DomainEnd(2) = nzlg
MemoryEnd(2) = nz
PatchEnd(2) = DomainEnd(2)
DomainStart(3) = 1
MemoryStart(3) = 1
PatchStart(3) = 1
DomainEnd(3) = bdywidth
MemoryEnd(3) = DomainEnd(3)
PatchEnd(3) = DomainEnd(3)
IF (io_form == 5) THEN
ilocs = (nx-fzone)*(loc_x-1)+fzone
jlocs = (ny-fzone)*(loc_y-1)+fzone
iloce = (nx-fzone)*(loc_x)+fzone
jloce = (ny-fzone)*(loc_y)+fzone
!
! West boudnary
!
DomainStart(1) = 1
DomainEnd(1) = nylg
MemoryStart(1) = jlocs
MemoryEnd(1) = jloce
PatchStart(1) = jlocs
PatchEnd(1) = jloce - fzone
IF (stagger == 'Y') THEN
IF (loc_y > 1 ) PatchStart(1) = jlocs + fzone
PatchEnd(1) = jloce
DimNames(1) = 'south_north_stag'
ELSE
DimNames(1) = 'south_north'
END IF
IOFLAG = .FALSE.
IF (loc_x == 1) IOFLAG = .TRUE.
! WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing West boundary for ', varname
CALL write_phdf5_bdy(nout,DateStr,varname//'XS',desc,'',stagger, &
bdyw, WRF_REAL, 1,'XSZ',DimNames, &
DomainStart,DomainEnd, &
MemoryStart,MemoryEnd, &
PatchStart,PatchEnd, IOFlag, istatus)
! IF (istatus == 0) THEN
! WRITE(6,'(a)') ' ... DONE.'
! ELSE
! WRITE(6,'(a,I3,a)') ' ... ERROR, ',istatus,'.'
! END IF
!
! East boudnary
!
IOFLAG = .FALSE.
IF (loc_x == nproc_x) IOFLAG = .TRUE.
! WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing East boundary for ', varname
CALL write_phdf5_bdy(nout,DateStr,varname//'XE',desc,'',stagger, &
bdye, WRF_REAL, 1, &
'XEZ',DimNames, &
DomainStart,DomainEnd, &
MemoryStart,MemoryEnd, &
PatchStart,PatchEnd, IOFlag, istatus)
! IF (istatus == 0) THEN
! WRITE(6,'(a)') ' ... DONE.'
! ELSE
! WRITE(6,'(a,I3,a)') ' ... ERROR, ',istatus,'.'
! END IF
!
! South boudnary
!
DomainStart(1) = 1
DomainEnd(1) = nxlg
MemoryStart(1) = ilocs
MemoryEnd(1) = iloce
PatchStart(1) = ilocs
PatchEnd(1) = iloce - fzone
IF (stagger == 'X') THEN
IF (loc_x > 1 ) PatchStart(1) = ilocs + fzone
PatchEnd(1) = iloce
DimNames(1) = 'west_east_stag'
ELSE
DimNames(1) = 'west_east'
END IF
IOFLAG = .FALSE.
IF (loc_y == 1) IOFLAG = .TRUE.
! WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing South boundary for ', varname
CALL write_phdf5_bdy(nout,DateStr,varname//'YS',desc,'',stagger, &
bdys, WRF_REAL, 1, &
'YSZ',DimNames, &
DomainStart,DomainEnd, &
MemoryStart,MemoryEnd, &
PatchStart,PatchEnd, IOFlag, istatus)
! IF (istatus == 0) THEN
! WRITE(6,'(a)') ' ... DONE.'
! ELSE
! WRITE(6,'(a,I3,a)') ' ... ERROR, ',istatus,'.'
! END IF
!
! North boudnary
!
IOFLAG = .FALSE.
IF (loc_y == nproc_y) IOFLAG = .TRUE.
! WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing North boundary for ', varname
CALL write_phdf5_bdy(nout,DateStr,varname//'YE',desc,'',stagger, &
bdyn, WRF_REAL, 1, &
'YEZ',DimNames, &
DomainStart,DomainEnd, &
MemoryStart,MemoryEnd, &
PatchStart,PatchEnd, IOFlag, istatus)
! IF (istatus == 0) THEN
! WRITE(6,'(a)') ' ... DONE.'
! ELSE
! WRITE(6,'(a,I3,a)') ' ... ERROR, ',istatus,'.'
! END IF
ELSE
IF (stagger == 'X') THEN
CALL wrf_mergebdyu(bdyw,bdye,bdys,bdyn,nx,ny,nz,bdywidth, &
fzone,dbdyw,dbdye,dbdys,dbdyn,tem1,tem2)
ELSE IF (stagger == 'Y') THEN
CALL wrf_mergebdyv(bdyw,bdye,bdys,bdyn,nx,ny,nz,bdywidth, &
fzone,dbdyw,dbdye,dbdys,dbdyn,tem1,tem2)
ELSE IF (stagger == 'Z') THEN
CALL wrf_mergebdyw(bdyw,bdye,bdys,bdyn,nx,ny,nz,bdywidth, &
fzone,dbdyw,dbdye,dbdys,dbdyn,tem1,tem2)
ELSE
CALL wrf_mergebdyt(bdyw,bdye,bdys,bdyn,nx,ny,nz,bdywidth, &
fzone,dbdyw,dbdye,dbdys,dbdyn,tem1,tem2)
END IF
IF (io_form == 1) THEN ! Binary
IF (myproc == 0) THEN
!
! West boudnary
!
DomainStart(1) = 1
DomainEnd(1) = nylg
IF (stagger == 'Y') THEN
DimNames(1) = 'south_north_stag'
ELSE
DimNames(1) = 'south_north'
END IF
WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing West boundary for ', varname
CALL ext_int_write_field( nout, DateStr,varname//'XS', &
dbdyw, WRF_REAL, 0, 0, 1, 'XSZ', Stagger, DimNames, &
DomainStart, DomainEnd, DomainStart, DomainEnd, &
DomainStart, DomainEnd, iStatus )
IF (istatus == 0) WRITE(6,'(a)') ' ... DONE.'
!
! East boudnary
!
WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing East boundary for ', varname
CALL ext_int_write_field( nout, DateStr,varname//'XE', &
dbdye, WRF_REAL, 0, 0, 1, 'XEZ', Stagger, DimNames, &
DomainStart, DomainEnd, DomainStart, DomainEnd, &
DomainStart, DomainEnd, iStatus )
IF (istatus == 0) WRITE(6,'(a)') ' ... DONE.'
!
! South boudnary
!
IF (stagger == 'X') THEN
DimNames(1) = 'west_east_stag'
ELSE
DimNames(1) = 'west_east'
END IF
DomainStart(1) = 1
DomainEnd(1) = nxlg
WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing South boundary for ', varname
CALL ext_int_write_field( nout, DateStr,varname//'YS', &
dbdys, WRF_REAL, 0, 0, 1, 'YSZ', Stagger, DimNames, &
DomainStart, DomainEnd, DomainStart, DomainEnd, &
DomainStart, DomainEnd, iStatus )
IF (istatus == 0) WRITE(6,'(a)') ' ... DONE.'
!
! North boudnary
!
WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing North boundary for ', varname
CALL ext_int_write_field( nout, DateStr,varname//'YE', &
dbdyn, WRF_REAL, 0, 0, 1, 'YEZ', Stagger, DimNames, &
DomainStart, DomainEnd, DomainStart, DomainEnd, &
DomainStart, DomainEnd, iStatus )
IF (istatus == 0) WRITE(6,'(a)') ' ... DONE.'
END IF
ELSE IF (io_form == 7) THEN ! NetCDF
IF (myproc == 0) &
CALL write_ncd_bdy(nout,nxlg,nylg,nzlg, bdywidth,itime,varname, &
dbdys,dbdyn,dbdyw,dbdye,istatus)
END IF
END IF
RETURN
END SUBROUTINE writebdy
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE writebdy2d ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE writebdy2d(nout,io_form,DateStr,itime,varname,stagger,desc, & 2,6
bdyw,bdye,bdys,bdyn,nx,ny,nz,bdywidth, &
fzone,dbdyw,dbdye,dbdys,dbdyn, &
nxlg,nylg,tem1,tem2)
!
!------------------------------------------------------------------
!
! PURPOSE:
!
! Write the 4 lateral boudnary arrays
!
!------------------------------------------------------------------
USE wrf_metadata
IMPLICIT NONE
INTEGER, INTENT(IN) :: nout
INTEGER, INTENT(IN) :: io_form
CHARACTER(LEN=*), INTENT(IN) :: DateStr
INTEGER, INTENT(IN) :: itime
CHARACTER(LEN=*), INTENT(IN) :: varname
CHARACTER(LEN=*), INTENT(IN) :: stagger
CHARACTER(LEN=*), INTENT(IN) :: desc
INTEGER, INTENT(IN) :: nx,ny,nz,bdywidth
INTEGER, INTENT(IN) :: fzone
REAL, INTENT(IN) :: bdys(nx,nz,bdywidth)
REAL, INTENT(IN) :: bdyn(nx,nz,bdywidth)
REAL, INTENT(IN) :: bdyw(ny,nz,bdywidth)
REAL, INTENT(IN) :: bdye(ny,nz,bdywidth)
INTEGER, INTENT(IN) :: nxlg,nylg
REAL, INTENT(IN) :: dbdys(nxlg,bdywidth)
REAL, INTENT(IN) :: dbdyn(nxlg,bdywidth)
REAL, INTENT(IN) :: dbdyw(nylg,bdywidth)
REAL, INTENT(IN) :: dbdye(nylg,bdywidth)
REAL, INTENT(OUT) :: tem1(nx,bdywidth)
REAL, INTENT(OUT) :: tem2(ny,bdywidth)
!------------------------------------------------------------------
!
! Misc. local variable
!
!------------------------------------------------------------------
INTEGER :: istatus
INCLUDE 'mp.inc'
CHARACTER(80) :: DimNames(3)
INTEGER :: DomainStart(3), DomainEnd(3)
INTEGER :: MemoryStart(3), MemoryEnd(3)
INTEGER :: PatchStart(3), PatchEnd(3)
INTEGER :: ilocs,iloce,jlocs,jloce
LOGICAL :: IOFLAG
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
DimNames(2) = 'bdy_width'
DimNames(3) = ''
DomainStart(2) = 1
DomainEnd(2) = bdywidth
DomainStart(3) = 1
DomainEnd(3) = 1
IF (io_form == 5) THEN
MemoryStart(2) = 1
MemoryEnd(2) = DomainEnd(2)
MemoryStart(3) = 1
MemoryEnd(3) = 1
PatchStart(2) = 1
PatchEnd(2) = DomainEnd(2)
PatchStart(3) = 1
PatchEnd(3) = 1
ilocs = (nx-fzone)*(loc_x-1)+fzone
jlocs = (ny-fzone)*(loc_y-1)+fzone
iloce = (nx-fzone)*(loc_x)+fzone
jloce = (ny-fzone)*(loc_y)+fzone
!
! West boudnary
!
DomainStart(1) = 1
DomainEnd(1) = nylg
MemoryStart(1) = jlocs
MemoryEnd(1) = jloce
PatchStart(1) = jlocs
PatchEnd(1) = jloce - fzone
IF (stagger == 'Y') THEN
IF (loc_y > 1 ) PatchStart(1) = jlocs + fzone
PatchEnd(1) = jloce
DimNames(1) = 'south_north_stag'
ELSE
DimNames(1) = 'south_north'
END IF
IOFLAG = .FALSE.
IF (loc_x == 1) IOFLAG = .TRUE.
tem2(:,:) = bdyw(:,1,:)
CALL write_phdf5_bdy(nout,DateStr,varname//'XS',desc,'',stagger, &
tem2, WRF_REAL, 1,'XS',DimNames, &
DomainStart,DomainEnd, &
MemoryStart,MemoryEnd, &
PatchStart,PatchEnd, &
IOFLAG,istatus)
!
! East boudnary
!
IOFLAG = .FALSE.
IF (loc_x == nproc_x) IOFLAG = .TRUE.
tem2(:,:) = bdye(:,1,:)
CALL write_phdf5_bdy(nout,DateStr,varname//'XE',desc,'',stagger, &
tem2, WRF_REAL, 1,'XE',DimNames, &
DomainStart,DomainEnd, &
MemoryStart,MemoryEnd, &
PatchStart,PatchEnd, &
IOFLAG,istatus)
!
! South boudnary
!
DomainStart(1) = 1
DomainEnd(1) = nxlg
MemoryStart(1) = ilocs
MemoryEnd(1) = iloce
PatchStart(1) = ilocs
PatchEnd(1) = iloce - fzone
IF (stagger == 'X') THEN
IF (loc_y > 1 ) PatchStart(1) = ilocs + fzone
PatchEnd(1) = iloce
DimNames(1) = 'west_east_stag'
ELSE
DimNames(1) = 'west_east'
END IF
IOFLAG = .FALSE.
IF (loc_y == 1) IOFLAG = .TRUE.
tem1(:,:) = bdys(:,1,:)
CALL write_phdf5_bdy(nout,DateStr,varname//'YS',desc,'',stagger, &
tem1, WRF_REAL, 1,'YS',DimNames, &
DomainStart,DomainEnd, &
MemoryStart,MemoryEnd, &
PatchStart,PatchEnd, IOFLAG,istatus)
!
! North boudnary
!
IOFLAG = .FALSE.
IF (loc_y == nproc_y) IOFLAG = .TRUE.
tem1(:,:) = bdyn(:,1,:)
CALL write_phdf5_bdy(nout,DateStr,varname//'YE',desc,'',stagger, &
tem1, WRF_REAL, 1,'YE',DimNames, &
DomainStart,DomainEnd, &
MemoryStart,MemoryEnd, &
PatchStart,PatchEnd, IOFLAG, istatus)
ELSE
IF (stagger == 'X') THEN
WRITE(0,*) 'WARNING: To be implemented, wrf_mergebdy2du.'
ELSE IF (stagger == 'Y') THEN
WRITE(0,*) 'WARNING: To be implemented, wrf_mergebdy2dv.'
ELSE IF (stagger == 'Z') THEN
WRITE(0,*) 'WARNING: To be implemented, wrf_mergebdy2dw.'
ELSE
CALL wrf_mergebdy2d(bdyw,bdye,bdys,bdyn,nx,ny,nz,bdywidth, &
fzone,dbdyw,dbdye,dbdys,dbdyn,tem1,tem2)
END IF
IF (io_form == 1) THEN ! binary
IF (myproc == 0) THEN
!
! West boudnary
!
DomainStart(1) = 1
DomainEnd(1) = nylg
IF (stagger == 'Y') THEN
DimNames(1) = 'south_north_stag'
ELSE
DimNames(1) = 'south_north'
END IF
WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing West boundary for ', varname
CALL ext_int_write_field( nout, DateStr,varname//'XS', &
dbdyw, WRF_REAL, 0, 0, 1, 'XS ', Stagger, DimNames, &
DomainStart, DomainEnd, DomainStart, DomainEnd, &
DomainStart, DomainEnd, iStatus )
IF (istatus == 0) WRITE(6,'(a)') ' ... DONE.'
!
! East boudnary
!
WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing East boundary for ', varname
CALL ext_int_write_field( nout, DateStr,varname//'XE', &
dbdye, WRF_REAL, 0, 0, 1, 'XE ', Stagger, DimNames, &
DomainStart, DomainEnd, DomainStart, DomainEnd, &
DomainStart, DomainEnd, iStatus )
IF (istatus == 0) WRITE(6,'(a)') ' ... DONE.'
!
! South boudnary
!
IF (stagger == 'X') THEN
DimNames(1) = 'west_east_stag'
ELSE
DimNames(1) = 'west_east'
END IF
DomainStart(1) = 1
DomainEnd(1) = nxlg
WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing South boundary for ', varname
CALL ext_int_write_field( nout, DateStr,varname//'YS', &
dbdys, WRF_REAL, 0, 0, 1, 'YS ', Stagger, DimNames, &
DomainStart, DomainEnd, DomainStart, DomainEnd, &
DomainStart, DomainEnd, iStatus )
IF (istatus == 0) WRITE(6,'(a)') ' ... DONE.'
!
! North boudnary
!
WRITE(6,FMT='(2a)',ADVANCE='NO') ' Writing North boundary for ', varname
CALL ext_int_write_field( nout, DateStr,varname//'YE', &
dbdyn, WRF_REAL, 0, 0, 1, 'YE ', Stagger, DimNames, &
DomainStart, DomainEnd, DomainStart, DomainEnd, &
DomainStart, DomainEnd, iStatus )
IF (istatus == 0) WRITE(6,'(a)') ' ... DONE.'
END IF
ELSE IF (io_form == 7) THEN ! NetCDF
IF (myproc == 0) &
CALL write_ncd_bdy2d(nout,nxlg,nylg,bdywidth,itime,varname, &
dbdys,dbdyn,dbdyw,dbdye,istatus)
END IF
END IF
RETURN
END SUBROUTINE writebdy2d