PageRenderTime 34ms CodeModel.GetById 24ms RepoModel.GetById 0ms app.codeStats 0ms

/wrfv2_fire/dyn_em/module_wps_io_arw.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 1944 lines | 1092 code | 300 blank | 552 comment | 68 complexity | 100ac757f26606a7119c8b03b77f8dce MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1. MODULE module_wps_io_arw
    2. 

  2. 

  3.    USE module_optional_input
    4. 

  4. 

  5.    IMPLICIT NONE
    6. 

  6. !! FROM MODULE_KINDS
    7. 

  7. 

  8. !   The numerical data types defined in this module are:
    9. 

  9. !      i_byte    - specification kind for byte (1-byte) integer variable
    10. 

  10. !      i_short   - specification kind for short (2-byte) integer variable
    11. 

  11. !      i_long    - specification kind for long (4-byte) integer variable
    12. 

  12. !      i_llong   - specification kind for double long (8-byte) integer variable
    13. 

  13. !      r_single  - specification kind for single precision (4-byte) real variable
    14. 

  14. !      r_double  - specification kind for double precision (8-byte) real variable
    15. 

  15. !      r_quad    - specification kind for quad precision (16-byte) real variable
    16. 

  16. !
    17. 

  17. !      i_kind    - generic specification kind for default integer
    18. 

  18. !      r_kind    - generic specification kind for default floating point
    19. 

  19. !
    20. 

  20. !
    21. 

  21. ! Integer type definitions below
    22. 

  22. 

  23. ! Integer types
    24. 

  24.   integer, parameter, public  :: i_byte  = selected_int_kind(1)      ! byte  integer
    25. 

  25.   integer, parameter, public  :: i_short = selected_int_kind(4)      ! short integer
    26. 

  26.   integer, parameter, public  :: i_long  = selected_int_kind(8)      ! long  integer
    27. 

  27.   integer, parameter, private :: llong_t = selected_int_kind(16)     ! llong integer
    28. 

  28.   integer, parameter, public  :: i_llong = max( llong_t, i_long )
    29. 

  29. 

  30. ! Expected 8-bit byte sizes of the integer kinds
    31. 

  31.   integer, parameter, public :: num_bytes_for_i_byte  = 1
    32. 

  32.   integer, parameter, public :: num_bytes_for_i_short = 2
    33. 

  33.   integer, parameter, public :: num_bytes_for_i_long  = 4
    34. 

  34.   integer, parameter, public :: num_bytes_for_i_llong = 8
    35. 

  35. 

  36. ! Define arrays for default definition
    37. 

  37.   integer, parameter, private :: num_i_kinds = 4
    38. 

  38.   integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ &
    39. 

  39.        i_byte, i_short, i_long,  i_llong  /) 
    40. 

  40.   integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ &
    41. 

  41.        num_bytes_for_i_byte, num_bytes_for_i_short, &
    42. 

  42.        num_bytes_for_i_long, num_bytes_for_i_llong  /)
    43. 

  43. 

  44. ! Default values
    45. 

  45. ! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND ***
    46. 

  46.   integer, parameter, private :: default_integer = 2  ! 1=byte, 
    47. 

  47.                                                       ! 2=short, 
    48. 

  48.                                                       ! 3=long, 
    49. 

  49.                                                       ! 4=llong
    50. 

  50.   integer, parameter, public  :: i_kind = integer_types( default_integer )
    51. 

  51.   integer, parameter, public  :: num_bytes_for_i_kind = &
    52. 

  52.        integer_byte_sizes( default_integer )
    53. 

  53. 

  54. 

  55. ! Real definitions below
    56. 

  56. 

  57. ! Real types
    58. 

  58.   integer, parameter, public  :: r_single = selected_real_kind(6)  ! single precision
    59. 

  59.   integer, parameter, public  :: r_double = selected_real_kind(15) ! double precision
    60. 

  60.   integer, parameter, private :: quad_t   = selected_real_kind(20) ! quad precision
    61. 

  61.   integer, parameter, public  :: r_quad   = max( quad_t, r_double )
    62. 

  62. 

  63. ! Expected 8-bit byte sizes of the real kinds
    64. 

  64.   integer, parameter, public :: num_bytes_for_r_single = 4
    65. 

  65.   integer, parameter, public :: num_bytes_for_r_double = 8
    66. 

  66.   integer, parameter, public :: num_bytes_for_r_quad   = 16
    67. 

  67. 

  68. ! Define arrays for default definition
    69. 

  69.   integer, parameter, private :: num_r_kinds = 3
    70. 

  70.   integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ &
    71. 

  71.        r_single, r_double, r_quad    /) 
    72. 

  72.   integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ &
    73. 

  73.        num_bytes_for_r_single, num_bytes_for_r_double, &
    74. 

  74.        num_bytes_for_r_quad    /)
    75. 

  75. 

  76. ! Default values
    77. 

  77. ! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND ***
    78. 

  78.   integer, parameter, private :: default_real = 2  ! 1=single, 
    79. 

  79.                                                    ! 2=double, 
    80. 

  80. !! END FROM MODULE_KINDS
    81. 

  81. 

  82.       !  Input 3D meteorological fields.
    83. 

  83. 

  84. 

  85.       REAL , DIMENSION(:,:,:) , ALLOCATABLE :: landuse_frac_input , &
    86. 

  86.                                                soil_top_cat_input , &
    87. 

  87.                                                soil_bot_cat_input
    88. 

  88. 

  89. 

  90.       !  Input 2D surface fields.
    91. 

  91. 

  92.       REAL , DIMENSION(:,:)   , ALLOCATABLE :: soilt010_input , soilt040_input , &
    93. 

  93.                                                soilt100_input , soilt200_input , &
    94. 

  94.                                                soilm010_input , soilm040_input , &
    95. 

  95.                                                soilm100_input , soilm200_input , &
    96. 

  96.                                                psfc_in,pmsl
    97. 

  97. 

  98.       REAL , DIMENSION(:,:)   , ALLOCATABLE :: lat_wind, lon_wind 
    99. 

  99. 

  100. 

  101.       !  Local input arrays
    102. 

  102. 

  103.       REAL,DIMENSION(:,:),ALLOCATABLE :: dum2d
    104. 

  104.       INTEGER,DIMENSION(:,:),ALLOCATABLE :: idum2d
    105. 

  105.       REAL,DIMENSION(:,:,:),ALLOCATABLE :: dum3d
    106. 

  106. 

  107.       LOGICAL , SAVE :: first_time_in = .TRUE.
    108. 

  108. 

  109.       INTEGER :: flag_soilt010 , flag_soilt100 , flag_soilt200 , &
    110. 

  110.         	 flag_soilm010 , flag_soilm100 , flag_soilm200
    111. 

  111. 

  112. !   Some constants to allow simple dimensions in the defined types
    113. 

  113. !   given below.
    114. 

  114. 

  115. 

  116. CONTAINS
    117. 

  117. 

  118.    SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels )
    119. 

  119. 

  120.       USE module_soil_pre
    121. 

  121.       USE module_domain
    122. 

  122. 

  123.       IMPLICIT NONE
    124. 

  124. 

  125.       TYPE(domain) , INTENT(INOUT)  :: grid
    126. 

  126.       CHARACTER (LEN=19) , INTENT(IN) :: file_date_string
    127. 

  127.       CHARACTER (LEN=4)              :: dummychar
    128. 

  128.       CHARACTER (LEN=132)              :: VarName
    129. 

  129.       CHARACTER (LEN=150)             :: chartemp
    130. 

  130.       CHARACTER (*) , INTENT(IN) :: filename
    131. 

  131. 

  132.       INTEGER :: ids,ide,jds,jde,kds,kde           &
    133. 

  133.                 ,ims,ime,jms,jme,kms,kme           &
    134. 

  134.                 ,its,ite,jts,jte,kts,kte
    135. 

  135. 

  136.       INTEGER :: i , j , k , loop, IMAX, JMAX
    137. 

  137.       INTEGER :: DATAHANDLE, num_metgrid_levels
    138. 

  138.       INTEGER :: Sysdepinfo, Status
    139. 

  139.       INTEGER :: istatus,ioutcount,iret,index,ierr
    140. 

  140.       
    141. 

  141.       integer :: nrecs,iunit, L,hor_size,hor_size_u,hor_size_v
    142. 

  142. 

  143. !!
    144. 

  144.       character*132, allocatable :: datestr_all(:)
    145. 

  145.       character*132, allocatable :: varname_all(:)
    146. 

  146.       integer, allocatable       :: domainend_all(:,:)
    147. 

  147.       integer, allocatable       :: start_block(:)
    148. 

  148.       integer, allocatable       :: end_block(:)
    149. 

  149.       integer, allocatable       :: start_byte(:)
    150. 

  150.       integer, allocatable       :: end_byte(:)
    151. 

  151.       integer(kind=i_llong), allocatable           :: file_offset(:)
    152. 

  152. !!
    153. 

  153. 

  154.       REAL :: dummy,tmp,garb
    155. 

  155.       REAL, ALLOCATABLE:: dumdata(:,:,:)
    156. 

  156.       REAL, ALLOCATABLE:: dumdata_u(:,:,:)
    157. 

  157.       REAL, ALLOCATABLE:: dumdata_v(:,:,:)
    158. 

  158. 

  159.       REAL :: lats16(16),lons16(16)
    160. 

  160. 

  161.       CHARACTER (LEN= 8) :: dummy_char
    162. 

  162. 

  163.       INTEGER :: ok , map_proj , ok_open, igarb,igarb2, N
    164. 

  164.       REAL :: pt
    165. 

  165.       INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
    166. 

  166. 

  167. #if defined(DM_PARALLEL) && !defined(STUBMPI)
    168. 

  168.       INCLUDE "mpif.h"
    169. 

  169. 

  170.       SELECT CASE ( model_data_order )
    171. 

  171.          CASE ( DATA_ORDER_ZXY )
    172. 

  172.             kds = grid%sd31 ; kde = grid%ed31 ;
    173. 

  173.             ids = grid%sd32 ; ide = grid%ed32 ;
    174. 

  174.             jds = grid%sd33 ; jde = grid%ed33 ;
    175. 

  175. 

  176.             kms = grid%sm31 ; kme = grid%em31 ;
    177. 

  177.             ims = grid%sm32 ; ime = grid%em32 ;
    178. 

  178.             jms = grid%sm33 ; jme = grid%em33 ;
    179. 

  179. 

  180.             kts = grid%sp31 ; kte = grid%ep31 ; ! tile is entire patch
    181. 

  181.             its = grid%sp32 ; ite = grid%ep32 ; ! tile is entire patch
    182. 

  182.             jts = grid%sp33 ; jte = grid%ep33 ; ! tile is entire patch
    183. 

  183. 

  184.          CASE ( DATA_ORDER_XYZ )
    185. 

  185.             ids = grid%sd31 ; ide = grid%ed31 ;
    186. 

  186.             jds = grid%sd32 ; jde = grid%ed32 ;
    187. 

  187.             kds = grid%sd33 ; kde = grid%ed33 ;
    188. 

  188. 

  189.             ims = grid%sm31 ; ime = grid%em31 ;
    190. 

  190.             jms = grid%sm32 ; jme = grid%em32 ;
    191. 

  191.             kms = grid%sm33 ; kme = grid%em33 ;
    192. 

  192. 

  193.             its = grid%sp31 ; ite = grid%ep31 ; ! tile is entire patch
    194. 

  194.             jts = grid%sp32 ; jte = grid%ep32 ; ! tile is entire patch
    195. 

  195.             kts = grid%sp33 ; kte = grid%ep33 ; ! tile is entire patch
    196. 

  196. 

  197.          CASE ( DATA_ORDER_XZY )
    198. 

  198.             ids = grid%sd31 ; ide = grid%ed31 ;
    199. 

  199.             kds = grid%sd32 ; kde = grid%ed32 ;
    200. 

  200.             jds = grid%sd33 ; jde = grid%ed33 ;
    201. 

  201. 

  202.             ims = grid%sm31 ; ime = grid%em31 ;
    203. 

  203.             kms = grid%sm32 ; kme = grid%em32 ;
    204. 

  204.             jms = grid%sm33 ; jme = grid%em33 ;
    205. 

  205. 

  206.             its = grid%sp31 ; ite = grid%ep31 ; ! tile is entire patch
    207. 

  207.             kts = grid%sp32 ; kte = grid%ep32 ; ! tile is entire patch
    208. 

  208.             jts = grid%sp33 ; jte = grid%ep33 ; ! tile is entire patch
    209. 

  209. 

  210.       END SELECT
    211. 

  211. 

  212.       !  Initialize what soil temperature and moisture is available.
    213. 

  213. 

  214. 

  215.       flag_st000010 = 0
    216. 

  216.       flag_st010040 = 0
    217. 

  217.       flag_st040100 = 0
    218. 

  218.       flag_st100200 = 0
    219. 

  219.       flag_sm000010 = 0 
    220. 

  220.       flag_sm010040 = 0
    221. 

  221.       flag_sm040100 = 0
    222. 

  222.       flag_sm100200 = 0
    223. 

  223.       flag_st010200 = 0
    224. 

  224.       flag_sm010200 = 0
    225. 

  225. 

  226.       flag_soilt010 = 0
    227. 

  227.       flag_soilt040 = 0
    228. 

  228.       flag_soilt100 = 0
    229. 

  229.       flag_soilt200 = 0 
    230. 

  230.       flag_soilm010 = 0 
    231. 

  231.       flag_soilm040 = 0
    232. 

  232.       flag_soilm100 = 0
    233. 

  233.       flag_soilm200 = 0
    234. 

  234. 

  235.       flag_sst      = 0
    236. 

  236.       flag_toposoil = 0
    237. 

  237. 

  238.       !  How many soil levels have we found?  Well, right now, none.
    239. 

  239. 

  240.       num_st_levels_input = 0
    241. 

  241.       num_sm_levels_input = 0
    242. 

  242.       st_levels_input = -1
    243. 

  243.       sm_levels_input = -1
    244. 

  244. 

  245.       !  Get the space for the data if this is the first time here.
    246. 

  246. 

  247. 

  248.         IF (.NOT. ALLOCATED (pmsl)              ) ALLOCATE ( pmsl(its:ite,jts:jte) )
    249. 

  249.         IF (.NOT. ALLOCATED (psfc_in)           ) ALLOCATE ( psfc_in(its:ite,jts:jte) )
    250. 

  250. 

  251. !!! MPI IO
    252. 

  252. 

  253.       iunit=33
    254. 

  254.       call count_recs_wrf_binary_file(iunit, trim(fileName), nrecs)
    255. 

  255. 

  256.       allocate (datestr_all(nrecs))
    257. 

  257.       allocate (varname_all(nrecs))
    258. 

  258.       allocate (domainend_all(3,nrecs))
    259. 

  259.       allocate (start_block(nrecs))
    260. 

  260.       allocate (end_block(nrecs))
    261. 

  261.       allocate (start_byte(nrecs))
    262. 

  262.       allocate (end_byte(nrecs))
    263. 

  263.       allocate (file_offset(nrecs))
    264. 

  264.  
    265. 

  265.       call inventory_wrf_binary_file(iunit, trim(filename), nrecs,  &
    266. 

  266.                       datestr_all,varname_all,domainend_all,   &
    267. 

  267.                       start_block,end_block,start_byte,end_byte,file_offset)
    268. 

  268. 

  269.       call mpi_file_open(mpi_comm_world, trim(filename),     &
    270. 

  270.                          mpi_mode_rdonly,mpi_info_null, iunit, ierr)
    271. 

  271.       if (ierr /= 0) then
    272. 

  272.        call wrf_error_fatal("Error opening file with mpi io")
    273. 

  273.       end if
    274. 

  274. 

  275.       VarName='CEN_LAT'
    276. 

  276.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    277. 

  277.       if (iret /= 0) then
    278. 

  278.         print*,VarName," not found in file"
    279. 

  279.       else
    280. 

  280. 

  281.         call mpi_file_read_at(iunit,file_offset(index)+5*4,      &
    282. 

  282.                               garb,1,mpi_real4,                  &
    283. 

  283.                               mpi_status_ignore, ierr)
    284. 

  284. 

  285.         if (ierr /= 0) then
    286. 

  286.           print*,"Error reading ", VarName," using MPIIO"
    287. 

  287.         else
    288. 

  288.           print*,VarName, ' from MPIIO READ= ',garb
    289. 

  289.           CALL nl_set_cen_lat ( grid%id , garb )
    290. 

  290.         end if
    291. 

  291.       end if
    292. 

  292. 

  293.       VarName='CEN_LON'
    294. 

  294.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    295. 

  295.         call mpi_file_read_at(iunit,file_offset(index)+5*4,      &
    296. 

  296.                               garb,1,mpi_real4,                  &
    297. 

  297.                               mpi_status_ignore, ierr)
    298. 

  298.           CALL nl_set_cen_lon ( grid%id , garb )
    299. 

  299.           CALL nl_set_stand_lon ( grid%id , garb )
    300. 

  300. 

  301.       VarName='POLE_LAT'
    302. 

  302.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    303. 

  303.         call mpi_file_read_at(iunit,file_offset(index)+5*4,      &
    304. 

  304.                               garb,1,mpi_real4,                  &
    305. 

  305.                               mpi_status_ignore, ierr)
    306. 

  306.           CALL nl_set_pole_lat ( grid%id , garb )
    307. 

  307. 

  308.       VarName='TRUELAT1'
    309. 

  309.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    310. 

  310.         call mpi_file_read_at(iunit,file_offset(index)+5*4,      &
    311. 

  311.                               garb,1,mpi_real4,                  &
    312. 

  312.                               mpi_status_ignore, ierr)
    313. 

  313.           CALL nl_set_truelat1 ( grid%id , garb )
    314. 

  314. 

  315.       VarName='TRUELAT2'
    316. 

  316.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    317. 

  317.         call mpi_file_read_at(iunit,file_offset(index)+5*4,      &
    318. 

  318.                               garb,1,mpi_real4,                  &
    319. 

  319.                               mpi_status_ignore, ierr)
    320. 

  320.           CALL nl_set_truelat2 ( grid%id , garb )
    321. 

  321. 

  322.       VarName='MAP_PROJ'
    323. 

  323.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    324. 

  324. 

  325.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    326. 

  326.                               igarb,1,mpi_integer4,             &
    327. 

  327.                               mpi_status_ignore, ierr)
    328. 

  328. 

  329.           CALL  nl_set_map_proj( grid%id, igarb)
    330. 

  330. 

  331.       VarName='ISURBAN'
    332. 

  332.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    333. 

  333.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    334. 

  334.                               igarb,1,mpi_integer4,             &
    335. 

  335.                               mpi_status_ignore, ierr)
    336. 

  336.           CALL  nl_set_isurban ( grid%id, igarb)
    337. 

  337. 

  338.       VarName='ISWATER'
    339. 

  339.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    340. 

  340.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    341. 

  341.                               igarb,1,mpi_integer4,             &
    342. 

  342.                               mpi_status_ignore, ierr)
    343. 

  343. 	write(0,*) 'setting iswater to be: ', igarb
    344. 

  344.         CALL nl_set_iswater (grid%id, igarb )
    345. 

  345. 

  346.       VarName='ISICE'
    347. 

  347.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    348. 

  348.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    349. 

  349.                               igarb2,1,mpi_integer4,             &
    350. 

  350.                               mpi_status_ignore, ierr)
    351. 

  351. 	write(0,*) 'setting isice to be: ', igarb2
    352. 

  352.         CALL nl_set_isice (grid%id, igarb2 )
    353. 

  353. 

  354.       IF ( igarb .eq. 16 .and. igarb2 .eq. 24 ) THEN
    355. 

  355.       CALL nl_set_mminlu ( grid%id, 'USGS')
    356. 

  356.       ENDIF
    357. 

  357. 

  358.       IF ( igarb .eq. 17 .and. igarb2 .eq. 15 ) THEN
    359. 

  359. ! ambiguous
    360. 

  360.       CALL nl_set_mminlu ( grid%id, 'MODIFIED_IGBP_MODIS_NOAH')
    361. 

  361. !      CALL nl_set_mminlu ( grid%id, 'MODIS')
    362. 

  362.       ENDIF
    363. 

  363. 

  364.       IF ( igarb .eq. 15 .and. igarb2 .eq. 16 ) THEN
    365. 

  365.       CALL nl_set_mminlu ( grid%id, 'SiB')
    366. 

  366.       ENDIF
    367. 

  367. 

  368.       VarName='FLAG_SNOWH'
    369. 

  369.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    370. 

  370.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    371. 

  371.                               igarb,1,mpi_integer4,             &
    372. 

  372.                               mpi_status_ignore, ierr)
    373. 

  373.         flag_snowh=igarb
    374. 

  374. 

  375.       VarName='FLAG_SNOW'
    376. 

  376.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    377. 

  377.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    378. 

  378.                               igarb,1,mpi_integer4,             &
    379. 

  379.                               mpi_status_ignore, ierr)
    380. 

  380.         flag_snow=igarb
    381. 

  381. 

  382.       VarName='FLAG_METGRID'
    383. 

  383.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    384. 

  384. 	if (iret .eq. 0) then
    385. 

  385.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    386. 

  386.                               igarb,1,mpi_integer4,             &
    387. 

  387.                               mpi_status_ignore, ierr)
    388. 

  388.         flag_metgrid=igarb
    389. 

  389. 	endif
    390. 

  390. 

  391.       VarName='FLAG_SOILHGT'
    392. 

  392.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    393. 

  393. 	if (iret .eq. 0) then
    394. 

  394.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    395. 

  395.                               igarb,1,mpi_integer4,             &
    396. 

  396.                               mpi_status_ignore, ierr)
    397. 

  397.         flag_soilhgt=igarb
    398. 

  398. 	endif
    399. 

  399. 

  400.       VarName='FLAG_PSFC'
    401. 

  401.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    402. 

  402. 	if (iret .eq. 0) then
    403. 

  403.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    404. 

  404.                               igarb,1,mpi_integer4,             &
    405. 

  405.                               mpi_status_ignore, ierr)
    406. 

  406.         flag_psfc=igarb
    407. 

  407. 	endif
    408. 

  408. 

  409.       VarName='FLAG_SLP'
    410. 

  410.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    411. 

  411. 	if (iret .eq. 0) then
    412. 

  412.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    413. 

  413.                               igarb,1,mpi_integer4,             &
    414. 

  414.                               mpi_status_ignore, ierr)
    415. 

  415.         flag_slp=igarb
    416. 

  416. 	endif
    417. 

  417. 

  418.       VarName='NUM_METGRID_SOIL_LEVELS'
    419. 

  419.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    420. 

  420.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    421. 

  421.                               igarb,1,mpi_integer4,             &
    422. 

  422.                               mpi_status_ignore, ierr)
    423. 

  423. 

  424.         CALL nl_set_num_metgrid_soil_levels(grid%id, igarb)
    425. 

  425.         num_sw_levels_input=igarb
    426. 

  426. 

  427. 

  428.       VarName='FLAG_SOIL_LEVELS'
    429. 

  429.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    430. 

  430. 	if (iret .eq. 0) then
    431. 

  431.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    432. 

  432.                               igarb,1,mpi_integer4,             &
    433. 

  433.                               mpi_status_ignore, ierr)
    434. 

  434.         flag_soil_levels=igarb
    435. 

  435. 	endif
    436. 

  436. 

  437. 

  438.       VarName='FLAG_SOIL_LAYERS'
    439. 

  439.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    440. 

  440.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    441. 

  441.                               igarb,1,mpi_integer4,             &
    442. 

  442.                               mpi_status_ignore, ierr)
    443. 

  443.         flag_soil_layers=igarb
    444. 

  444. 

  445. 

  446. 

  447.       VarName='ISLAKE'
    448. 

  448.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    449. 

  449.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    450. 

  450.                               igarb,1,mpi_integer4,             &
    451. 

  451.                               mpi_status_ignore, ierr)
    452. 

  452.           CALL  nl_set_islake ( grid%id, igarb)
    453. 

  453. 

  454.       VarName='ISOILWATER'
    455. 

  455.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    456. 

  456.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    457. 

  457.                               igarb,1,mpi_integer4,             &
    458. 

  458.                               mpi_status_ignore, ierr)
    459. 

  459.           CALL  nl_set_isoilwater ( grid%id, igarb)
    460. 

  460. 

  461.       VarName='MOAD_CEN_LAT'
    462. 

  462.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    463. 

  463.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    464. 

  464.                               garb,1,mpi_real4,             &
    465. 

  465.                               mpi_status_ignore, ierr)
    466. 

  466.           CALL  nl_set_moad_cen_lat ( grid%id,garb)
    467. 

  467. 

  468.       VarName='corner_lats'
    469. 

  469.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    470. 

  470.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    471. 

  471.                               lats16,16,mpi_real4,             &
    472. 

  472.                               mpi_status_ignore, ierr)
    473. 

  473. 

  474.       VarName='corner_lons'
    475. 

  475.       call retrieve_index(index,VarName,varname_all,nrecs,iret)
    476. 

  476.         call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    477. 

  477.                               lons16,16,mpi_real4,             &
    478. 

  478.                               mpi_status_ignore, ierr)
    479. 

  479. 

  480. !      VarName='MMINLU'
    481. 

  481. !      call retrieve_index(index,VarName,varname_all,nrecs,iret)
    482. 

  482. !	if (iret .eq. 0) then
    483. 

  483. !       call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
    484. 

  484. !                              dummychar,1,mpi_char,             &
    485. 

  485. !                              mpi_status_ignore, ierr)
    486. 

  486. !        endif
    487. 

  487. 

  488.     hor_size=(IDE-IDS)*(JDE-JDS)
    489. 

  489.     hor_size_u=(IDE+1-IDS)*(JDE-JDS)
    490. 

  490.     hor_size_v=(IDE-IDS)*(JDE+1-JDS)
    491. 

  491. 

  492.     varName='PRES'
    493. 

  493.     allocate(dumdata(IDS:IDE-1,JDS:JDE-1,num_metgrid_levels))
    494. 

  494.     allocate(dumdata_u(IDS:IDE,JDS:JDE-1,num_metgrid_levels))
    495. 

  495.     allocate(dumdata_v(IDS:IDE-1,JDS:JDE,num_metgrid_levels))
    496. 

  496. 

  497.      CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    498. 

  498.      CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    499. 

  499.                           dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
    500. 

  500.                           mpi_status_ignore, ierr)
    501. 

  501. 

  502. 

  503.        DO K=1,num_metgrid_levels
    504. 

  504.         DO J=JTS,min(JTE,JDE-1)
    505. 

  505.          DO I=ITS,min(ITE,IDE-1)
    506. 

  506.            grid%p_gc(I,K,J)=dumdata(I,J,K)
    507. 

  507.          ENDDO
    508. 

  508.         ENDDO
    509. 

  509.        ENDDO
    510. 

  510. 

  511. 

  512.     varName='GHT'
    513. 

  513.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    514. 

  514.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    515. 

  515.                              dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
    516. 

  516.                              mpi_status_ignore, ierr)
    517. 

  517. 

  518. 

  519.        DO K=1,num_metgrid_levels
    520. 

  520.         DO J=JTS,min(JTE,JDE-1)
    521. 

  521.          DO I=ITS,min(ITE,IDE-1)
    522. 

  522.            grid%ght_gc(I,K,J)=dumdata(I,J,K)
    523. 

  523.          ENDDO
    524. 

  524.         ENDDO
    525. 

  525.        ENDDO
    526. 

  526. 

  527.     varName='VEGCAT'
    528. 

  528.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    529. 

  529.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    530. 

  530.                              dumdata,hor_size,mpi_real4,             &
    531. 

  531.                              mpi_status_ignore, ierr)
    532. 

  532. 

  533.         DO J=JTS,min(JTE,JDE-1)
    534. 

  534.          DO I=ITS,min(ITE,IDE-1)
    535. 

  535.            grid%vegcat(I,J)=dumdata(I,J,1)
    536. 

  536.          ENDDO
    537. 

  537.         ENDDO
    538. 

  538. 

  539. !    varName='SOIL_CAT'
    540. 

  540. !    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    541. 

  541. !    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    542. 

  542. !                             dumdata,hor_size,mpi_real4,             &
    543. 

  543. !                             mpi_status_ignore, ierr)
    544. 

  544. !        DO J=JTS,min(JTE,JDE-1)
    545. 

  545. !         DO I=ITS,min(ITE,IDE-1)
    546. 

  546. !           grid%input_soil_cat(I,J)=dumdata(I,J,1)
    547. 

  547. !         ENDDO
    548. 

  548. !        ENDDO
    549. 

  549. 

  550.     varName='CANWAT'
    551. 

  551.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    552. 

  552.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    553. 

  553.                              dumdata,hor_size,mpi_real4,             &
    554. 

  554.                              mpi_status_ignore, ierr)
    555. 

  555. 

  556.         DO J=JTS,min(JTE,JDE-1)
    557. 

  557.          DO I=ITS,min(ITE,IDE-1)
    558. 

  558.            grid%canwat(I,J)=dumdata(I,J,1)
    559. 

  559.          ENDDO
    560. 

  560.         ENDDO
    561. 

  561. 

  562.     varName='SNOW'
    563. 

  563.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    564. 

  564.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    565. 

  565.                              dumdata,hor_size,mpi_real4,             &
    566. 

  566.                              mpi_status_ignore, ierr)
    567. 

  567.         DO J=JTS,min(JTE,JDE-1)
    568. 

  568.          DO I=ITS,min(ITE,IDE-1)
    569. 

  569.            grid%snow(I,J)=dumdata(I,J,1)
    570. 

  570.          ENDDO
    571. 

  571.         ENDDO
    572. 

  572. 

  573.     varName='SNOWH'
    574. 

  574.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    575. 

  575.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    576. 

  576.                              dumdata,hor_size,mpi_real4,             &
    577. 

  577.                              mpi_status_ignore, ierr)
    578. 

  578.         DO J=JTS,min(JTE,JDE-1)
    579. 

  579.          DO I=ITS,min(ITE,IDE-1)
    580. 

  580.            grid%snowh(I,J)=dumdata(I,J,1)
    581. 

  581.          ENDDO
    582. 

  582.         ENDDO
    583. 

  583. 

  584.     varName='SKINTEMP'
    585. 

  585.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    586. 

  586.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    587. 

  587.                              dumdata,hor_size,mpi_real4,             &
    588. 

  588.                              mpi_status_ignore, ierr)
    589. 

  589.         DO J=JTS,min(JTE,JDE-1)
    590. 

  590.          DO I=ITS,min(ITE,IDE-1)
    591. 

  591.            grid%tsk_gc(I,J)=dumdata(I,J,1)
    592. 

  592.          ENDDO
    593. 

  593.         ENDDO
    594. 

  594. 

  595.     varName='SOILHGT'
    596. 

  596.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    597. 

  597.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    598. 

  598.                              dumdata,hor_size,mpi_real4,             &
    599. 

  599.                              mpi_status_ignore, ierr)
    600. 

  600.         DO J=JTS,min(JTE,JDE-1)
    601. 

  601.          DO I=ITS,min(ITE,IDE-1)
    602. 

  602.            grid%toposoil(I,J)=dumdata(I,J,1)
    603. 

  603.          ENDDO
    604. 

  604.         ENDDO
    605. 

  605. 

  606. !    varName='SEAICE'
    607. 

  607. !    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    608. 

  608. !    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    609. 

  609. !                             dumdata,hor_size,mpi_real4,             &
    610. 

  610. !                             mpi_status_ignore, ierr)
    611. 

  611. !        DO J=JTS,min(JTE,JDE-1)
    612. 

  612. !         DO I=ITS,min(ITE,IDE-1)
    613. 

  613. !           grid%xice_gc(I,J)=dumdata(I,J,1)
    614. 

  614. !         ENDDO
    615. 

  615. !        ENDDO
    616. 

  616. 

  617.     varName='ST100200'
    618. 

  618.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    619. 

  619.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    620. 

  620.                              dumdata,hor_size,mpi_real4,             &
    621. 

  621.                              mpi_status_ignore, ierr)
    622. 

  622.         DO J=JTS,min(JTE,JDE-1)
    623. 

  623.          DO I=ITS,min(ITE,IDE-1)
    624. 

  624.            grid%st100200(I,J)=dumdata(I,J,1)
    625. 

  625.          ENDDO
    626. 

  626.         ENDDO
    627. 

  627. 

  628.     varName='ST040100'
    629. 

  629.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    630. 

  630.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    631. 

  631.                              dumdata,hor_size,mpi_real4,             &
    632. 

  632.                              mpi_status_ignore, ierr)
    633. 

  633.         DO J=JTS,min(JTE,JDE-1)
    634. 

  634.          DO I=ITS,min(ITE,IDE-1)
    635. 

  635.            grid%st040100(I,J)=dumdata(I,J,1)
    636. 

  636.          ENDDO
    637. 

  637.         ENDDO
    638. 

  638. 

  639.     varName='ST010040'
    640. 

  640.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    641. 

  641.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    642. 

  642.                              dumdata,hor_size,mpi_real4,             &
    643. 

  643.                              mpi_status_ignore, ierr)
    644. 

  644. 

  645.         DO J=JTS,min(JTE,JDE-1)
    646. 

  646.          DO I=ITS,min(ITE,IDE-1)
    647. 

  647.            grid%st010040(I,J)=dumdata(I,J,1)
    648. 

  648.          ENDDO
    649. 

  649.         ENDDO
    650. 

  650. 

  651.     varName='ST000010'
    652. 

  652.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    653. 

  653.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    654. 

  654.                              dumdata,hor_size,mpi_real4,             &
    655. 

  655.                              mpi_status_ignore, ierr)
    656. 

  656. 

  657.         DO J=JTS,min(JTE,JDE-1)
    658. 

  658.          DO I=ITS,min(ITE,IDE-1)
    659. 

  659.            grid%st000010(I,J)=dumdata(I,J,1)
    660. 

  660.          ENDDO
    661. 

  661.         ENDDO
    662. 

  662. 

  663.     varName='SM100200'
    664. 

  664.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    665. 

  665.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    666. 

  666.                              dumdata,hor_size,mpi_real4,             &
    667. 

  667.                              mpi_status_ignore, ierr)
    668. 

  668. 

  669.         DO J=JTS,min(JTE,JDE-1)
    670. 

  670.          DO I=ITS,min(ITE,IDE-1)
    671. 

  671.            grid%sm100200(I,J)=dumdata(I,J,1)
    672. 

  672.          ENDDO
    673. 

  673.         ENDDO
    674. 

  674. 

  675.     varName='SM040100'
    676. 

  676.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    677. 

  677.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    678. 

  678.                              dumdata,hor_size,mpi_real4,             &
    679. 

  679.                              mpi_status_ignore, ierr)
    680. 

  680. 

  681.         DO J=JTS,min(JTE,JDE-1)
    682. 

  682.          DO I=ITS,min(ITE,IDE-1)
    683. 

  683.            grid%sm040100(I,J)=dumdata(I,J,1)
    684. 

  684.          ENDDO
    685. 

  685.         ENDDO
    686. 

  686. 

  687.     varName='SM010040'
    688. 

  688.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    689. 

  689.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    690. 

  690.                              dumdata,hor_size,mpi_real4,             &
    691. 

  691.                              mpi_status_ignore, ierr)
    692. 

  692. 

  693.         DO J=JTS,min(JTE,JDE-1)
    694. 

  694.          DO I=ITS,min(ITE,IDE-1)
    695. 

  695.            grid%sm010040(I,J)=dumdata(I,J,1)
    696. 

  696.          ENDDO
    697. 

  697.         ENDDO
    698. 

  698. 

  699.     varName='SM000010'
    700. 

  700.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    701. 

  701.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    702. 

  702.                              dumdata,hor_size,mpi_real4,             &
    703. 

  703.                              mpi_status_ignore, ierr)
    704. 

  704. 

  705.         DO J=JTS,min(JTE,JDE-1)
    706. 

  706.          DO I=ITS,min(ITE,IDE-1)
    707. 

  707.            grid%sm000010(I,J)=dumdata(I,J,1)
    708. 

  708.          ENDDO
    709. 

  709.         ENDDO
    710. 

  710. 

  711.     varName='PSFC'
    712. 

  712.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    713. 

  713.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    714. 

  714.                              dumdata,hor_size,mpi_real4,             &
    715. 

  715.                              mpi_status_ignore, ierr)
    716. 

  716. 

  717. 	if ( ierr .eq. 0 ) flag_psfc=1
    718. 

  718. 

  719.         DO J=JTS,min(JTE,JDE-1)
    720. 

  720.          DO I=ITS,min(ITE,IDE-1)
    721. 

  721.            grid%psfc(I,J)=dumdata(I,J,1)
    722. 

  722.          ENDDO
    723. 

  723.         ENDDO
    724. 

  724. 

  725.     varName='RH'
    726. 

  726.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    727. 

  727.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    728. 

  728.                              dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
    729. 

  729.                              mpi_status_ignore, ierr)
    730. 

  730. 

  731.        DO K=1,num_metgrid_levels
    732. 

  732.         DO J=JTS,min(JTE,JDE-1)
    733. 

  733.          DO I=ITS,min(ITE,IDE-1)
    734. 

  734.            grid%rh_gc(I,K,J)=dumdata(I,J,K)
    735. 

  735.          ENDDO
    736. 

  736.         ENDDO
    737. 

  737.        ENDDO
    738. 

  738. 

  739.     varName='VV'
    740. 

  740.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    741. 

  741.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    742. 

  742.                              dumdata_v,hor_size_v*num_metgrid_levels,mpi_real4,             &
    743. 

  743.                              mpi_status_ignore, ierr)
    744. 

  744. 

  745.        DO K=1,num_metgrid_levels
    746. 

  746.         DO J=JTS,min(JTE,JDE)
    747. 

  747.          DO I=ITS,min(ITE,IDE-1)
    748. 

  748.            grid%v_gc(I,K,J)=dumdata_v(I,J,K)
    749. 

  749. 	if (grid%v_gc(I,K,J) .ne. grid%v_gc(I,K,J) .or. abs(grid%v_gc(I,K,J)) .gt. 100.) then
    750. 

  750. 	write(0,*) 'bad v_gc defined: ', I,K,J,grid%v_gc(I,K,J)
    751. 

  751. 	call wrf_error_fatal(" bad v_gc")
    752. 

  752. 	endif
    753. 

  753.          ENDDO
    754. 

  754.         ENDDO
    755. 

  755.        ENDDO
    756. 

  756. 

  757.     varName='UU'
    758. 

  758.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    759. 

  759.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    760. 

  760.                              dumdata_u,hor_size_u*num_metgrid_levels,mpi_real4,             &
    761. 

  761.                              mpi_status_ignore, ierr)
    762. 

  762.        DO K=1,num_metgrid_levels
    763. 

  763.         DO J=JTS,min(JTE,JDE-1)
    764. 

  764.          DO I=ITS,min(ITE,IDE)
    765. 

  765.            grid%u_gc(I,K,J)=dumdata_u(I,J,K)
    766. 

  766. 	if (grid%u_gc(I,K,J) .ne. grid%u_gc(I,K,J) .or. abs(grid%u_gc(I,K,J)) .gt. 100.) then
    767. 

  767. 	write(0,*) 'bad u_gc defined: ', I,K,J,grid%u_gc(I,K,J)
    768. 

  768. 	call wrf_error_fatal(" bad u_gc")
    769. 

  769. 	endif
    770. 

  770.          ENDDO
    771. 

  771.         ENDDO
    772. 

  772.        ENDDO
    773. 

  773. 

  774.     varName='TT'
    775. 

  775.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    776. 

  776.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    777. 

  777.                              dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
    778. 

  778.                              mpi_status_ignore, ierr)
    779. 

  779.        DO K=1,num_metgrid_levels
    780. 

  780.         DO J=JTS,min(JTE,JDE-1)
    781. 

  781.          DO I=ITS,min(ITE,IDE-1)
    782. 

  782.            grid%t_gc(I,K,J)=dumdata(I,J,K)
    783. 

  783. 	if (grid%t_gc(I,K,J) .ne. grid%t_gc(I,K,J) .or. abs(grid%t_gc(I,K,J)) .gt. 350.) then
    784. 

  784. 	write(0,*) 'bad t_gc defined: ', I,K,J,grid%t_gc(I,K,J)
    785. 

  785. 	call wrf_error_fatal(" bad t_gc")
    786. 

  786. 	endif
    787. 

  787.          ENDDO
    788. 

  788.         ENDDO
    789. 

  789.        ENDDO
    790. 

  790. 

  791. !    varName='RWMR'
    792. 

  792. !    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    793. 

  793. !    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    794. 

  794. !                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
    795. 

  795. !                             mpi_status_ignore, ierr)
    796. 

  796. !       DO K=1,num_metgrid_levels
    797. 

  797. !        DO J=JTS,min(JTE,JDE-1)
    798. 

  798. !         DO I=ITS,min(ITE,IDE-1)
    799. 

  799. !           grid%nmm_rwmr_gc(I,J,K)=dumdata(I,J,K)
    800. 

  800. !         ENDDO
    801. 

  801. !        ENDDO
    802. 

  802. !       ENDDO
    803. 

  803. 

  804. !    varName='SNMR'
    805. 

  805. !    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    806. 

  806. !    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    807. 

  807. !                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
    808. 

  808. !                             mpi_status_ignore, ierr)
    809. 

  809. !       DO K=1,num_metgrid_levels
    810. 

  810. !        DO J=JTS,min(JTE,JDE-1)
    811. 

  811. !         DO I=ITS,min(ITE,IDE-1)
    812. 

  812. !           grid%nmm_snmr_gc(I,J,K)=dumdata(I,J,K)
    813. 

  813. !         ENDDO
    814. 

  814. !        ENDDO
    815. 

  815. !       ENDDO
    816. 

  816. 

  817. !    varName='CLWMR'
    818. 

  818. !    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    819. 

  819. !    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    820. 

  820. !                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
    821. 

  821. !                             mpi_status_ignore, ierr)
    822. 

  822. !       DO K=1,num_metgrid_levels
    823. 

  823. !        DO J=JTS,min(JTE,JDE-1)
    824. 

  824. !         DO I=ITS,min(ITE,IDE-1)
    825. 

  825. !           grid%nmm_clwmr_gc(I,J,K)=dumdata(I,J,K)
    826. 

  826. !         ENDDO
    827. 

  827. !        ENDDO
    828. 

  828. !       ENDDO
    829. 

  829. 

  830. !    varName='CICE'
    831. 

  831. !    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    832. 

  832. !    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    833. 

  833. !                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
    834. 

  834. !                             mpi_status_ignore, ierr)
    835. 

  835. !       DO K=1,num_metgrid_levels
    836. 

  836. !        DO J=JTS,min(JTE,JDE-1)
    837. 

  837. !         DO I=ITS,min(ITE,IDE-1)
    838. 

  838. !           grid%nmm_cice_gc(I,J,K)=dumdata(I,J,K)
    839. 

  839. !         ENDDO
    840. 

  840. !        ENDDO
    841. 

  841. !       ENDDO
    842. 

  842. 

  843. !    varName='FRIMEF'
    844. 

  844. !    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    845. 

  845. !    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    846. 

  846. !                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
    847. 

  847. !                             mpi_status_ignore, ierr)
    848. 

  848. !       DO K=1,num_metgrid_levels
    849. 

  849. !        DO J=JTS,min(JTE,JDE-1)
    850. 

  850. !         DO I=ITS,min(ITE,IDE-1)
    851. 

  851. !           grid%nmm_rimef_gc(I,J,K)=dumdata(I,J,K)
    852. 

  852. !         ENDDO
    853. 

  853. !        ENDDO
    854. 

  854. !       ENDDO
    855. 

  855. 

  856. 

  857.      varName='PMSL'
    858. 

  858.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    859. 

  859.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    860. 

  860.                              dumdata,hor_size,mpi_real4,             &
    861. 

  861.                              mpi_status_ignore, ierr)
    862. 

  862.         DO J=JTS,min(JTE,JDE-1)
    863. 

  863.          DO I=ITS,min(ITE,IDE-1)
    864. 

  864.            grid%pslv_gc(I,J)=dumdata(I,J,1)
    865. 

  865.          ENDDO
    866. 

  866.         ENDDO
    867. 

  867. 

  868. 

  869.     varName='SLOPECAT'
    870. 

  870.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    871. 

  871.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    872. 

  872.                              dumdata,hor_size,mpi_real4,             &
    873. 

  873.                              mpi_status_ignore, ierr)
    874. 

  874.         DO J=JTS,min(JTE,JDE-1)
    875. 

  875.          DO I=ITS,min(ITE,IDE-1)
    876. 

  876.            grid%slopecat(I,J)=dumdata(I,J,1)
    877. 

  877.          ENDDO
    878. 

  878.         ENDDO
    879. 

  879. 

  880.     varName='SNOALB'
    881. 

  881.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    882. 

  882.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    883. 

  883.                              dumdata,hor_size,mpi_real4,             &
    884. 

  884.                              mpi_status_ignore, ierr)
    885. 

  885. 

  886.         DO J=JTS,min(JTE,JDE-1)
    887. 

  887.          DO I=ITS,min(ITE,IDE-1)
    888. 

  888.            grid%snoalb(I,J)=dumdata(I,J,1)
    889. 

  889.          ENDDO
    890. 

  890.         ENDDO
    891. 

  891. 

  892.          num_veg_cat      = SIZE ( grid%landusef , DIM=2 )
    893. 

  893.          num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 )
    894. 

  894.          num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 )
    895. 

  895. 

  896.     varName='GREENFRAC'
    897. 

  897.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    898. 

  898.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    899. 

  899.                              dumdata,hor_size*12,mpi_real4,             &
    900. 

  900.                              mpi_status_ignore, ierr)
    901. 

  901. 

  902.        DO K=1,12
    903. 

  903.         DO J=JTS,min(JTE,JDE-1)
    904. 

  904.          DO I=ITS,min(ITE,IDE-1)
    905. 

  905.            grid%greenfrac(I,K,J)=dumdata(I,J,K)
    906. 

  906.          ENDDO
    907. 

  907.         ENDDO
    908. 

  908.        ENDDO
    909. 

  909. 

  910.     varName='ALBEDO12M'
    911. 

  911.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    912. 

  912.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    913. 

  913.                              dumdata,hor_size*12,mpi_real4,             &
    914. 

  914.                              mpi_status_ignore, ierr)
    915. 

  915. 

  916.        DO K=1,12
    917. 

  917.         DO J=JTS,min(JTE,JDE-1)
    918. 

  918.          DO I=ITS,min(ITE,IDE-1)
    919. 

  919.            grid%albedo12m(I,K,J)=dumdata(I,J,K)
    920. 

  920.          ENDDO
    921. 

  921.         ENDDO
    922. 

  922.        ENDDO
    923. 

  923. 

  924.     varName='SOILCBOT'
    925. 

  925.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    926. 

  926.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    927. 

  927.                              dumdata,hor_size*num_soil_bot_cat,mpi_real4,             &
    928. 

  928.                              mpi_status_ignore, ierr)
    929. 

  929. 

  930.        DO K=1,num_soil_bot_cat
    931. 

  931.         DO J=JTS,min(JTE,JDE-1)
    932. 

  932.          DO I=ITS,min(ITE,IDE-1)
    933. 

  933.            grid%soilcbot(I,K,J)=dumdata(I,J,K)
    934. 

  934.          ENDDO
    935. 

  935.         ENDDO
    936. 

  936.        ENDDO
    937. 

  937. 

  938.     varName='SOILCAT'
    939. 

  939.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    940. 

  940.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    941. 

  941.                              dumdata,hor_size,mpi_real4,             &
    942. 

  942.                              mpi_status_ignore, ierr)
    943. 

  943. 

  944.         DO J=JTS,min(JTE,JDE-1)
    945. 

  945.          DO I=ITS,min(ITE,IDE-1)
    946. 

  946.            grid%soilcat(I,J)=dumdata(I,J,1)
    947. 

  947.          ENDDO
    948. 

  948.         ENDDO
    949. 

  949. 

  950. 	write(0,*) 'veg_cat and soil_cat sizes:::: ', num_veg_cat , num_soil_top_cat
    951. 

  951. 

  952.     varName='SOILCTOP'
    953. 

  953.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    954. 

  954.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    955. 

  955.                              dumdata,hor_size*num_soil_top_cat,mpi_real4,             &
    956. 

  956.                              mpi_status_ignore, ierr)
    957. 

  957.        DO K=1,num_soil_top_cat
    958. 

  958.         DO J=JTS,min(JTE,JDE-1)
    959. 

  959.          DO I=ITS,min(ITE,IDE-1)
    960. 

  960.            grid%soilctop(I,K,J)=dumdata(I,J,K)
    961. 

  961.          ENDDO
    962. 

  962.         ENDDO
    963. 

  963.        ENDDO
    964. 

  964. 

  965.     varName='SOILTEMP'
    966. 

  966.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    967. 

  967.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    968. 

  968.                              dumdata,hor_size,mpi_real4,             &
    969. 

  969.                              mpi_status_ignore, ierr)
    970. 

  970. 

  971.         DO J=JTS,min(JTE,JDE-1)
    972. 

  972.          DO I=ITS,min(ITE,IDE-1)
    973. 

  973.            grid%tmn_gc(I,J)=dumdata(I,J,1)
    974. 

  974.          ENDDO
    975. 

  975.         ENDDO
    976. 

  976. 

  977. !    varName='HGT_V'
    978. 

  978. !    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    979. 

  979. !    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    980. 

  980. !                             dumdata,hor_size,mpi_real4,             &
    981. 

  981. !                             mpi_status_ignore, ierr)
    982. 

  982. !
    983. 

  983. !        DO J=JTS,min(JTE,JDE-1)
    984. 

  984. !         DO I=ITS,min(ITE,IDE-1)
    985. 

  985. !           grid%nmm_htv_gc(I,J)=dumdata(I,J,1)
    986. 

  986. !         ENDDO
    987. 

  987. !        ENDDO
    988. 

  988. 

  989.     varName='HGT_M'
    990. 

  990.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    991. 

  991.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    992. 

  992.                              dumdata,hor_size,mpi_real4,             &
    993. 

  993.                              mpi_status_ignore, ierr)
    994. 

  994. 

  995.         DO J=JTS,min(JTE,JDE-1)
    996. 

  996.          DO I=ITS,min(ITE,IDE-1)
    997. 

  997.            grid%ht_gc(I,J)=dumdata(I,J,1)
    998. 

  998.          ENDDO
    999. 

  999.         ENDDO
    1000. 

  1000. 

  1001.     varName='LU_INDEX'
    1002. 

  1002.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1003. 

  1003.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1004. 

  1004.                              dumdata,hor_size,mpi_real4,             &
    1005. 

  1005.                              mpi_status_ignore, ierr)
    1006. 

  1006. 

  1007.         DO J=JTS,min(JTE,JDE-1)
    1008. 

  1008.          DO I=ITS,min(ITE,IDE-1)
    1009. 

  1009.            grid%lu_index(I,J)=dumdata(I,J,1)
    1010. 

  1010.          ENDDO
    1011. 

  1011.         ENDDO
    1012. 

  1012. 

  1013.     varName='LANDUSEF'
    1014. 

  1014.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1015. 

  1015.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1016. 

  1016.                              dumdata,hor_size*num_veg_cat,mpi_real4,             &
    1017. 

  1017.                              mpi_status_ignore, ierr)
    1018. 

  1018. 

  1019.        DO K=1,num_veg_cat
    1020. 

  1020.         DO J=JTS,min(JTE,JDE-1)
    1021. 

  1021.          DO I=ITS,min(ITE,IDE-1)
    1022. 

  1022.            grid%landusef(I,K,J)=dumdata(I,J,K)
    1023. 

  1023.          ENDDO
    1024. 

  1024.         ENDDO
    1025. 

  1025.        ENDDO
    1026. 

  1026. 

  1027.     varName='LANDMASK'
    1028. 

  1028.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1029. 

  1029.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1030. 

  1030.                              dumdata,hor_size,mpi_real4,             &
    1031. 

  1031.                              mpi_status_ignore, ierr)
    1032. 

  1032. 

  1033.         DO J=JTS,min(JTE,JDE-1)
    1034. 

  1034.          DO I=ITS,min(ITE,IDE-1)
    1035. 

  1035.            grid%landmask(I,J)=dumdata(I,J,1)
    1036. 

  1036.          ENDDO
    1037. 

  1037.         ENDDO
    1038. 

  1038. 

  1039.     varName='F'
    1040. 

  1040.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1041. 

  1041.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1042. 

  1042.                              dumdata,hor_size,mpi_real4,             &
    1043. 

  1043.                              mpi_status_ignore, ierr)
    1044. 

  1044.         DO J=JTS,min(JTE,JDE-1)
    1045. 

  1045.          DO I=ITS,min(ITE,IDE-1)
    1046. 

  1046.            grid%f(I,J)=dumdata(I,J,1)
    1047. 

  1047.          ENDDO
    1048. 

  1048.         ENDDO
    1049. 

  1049. 

  1050.     varName='E'
    1051. 

  1051.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1052. 

  1052.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1053. 

  1053.                              dumdata,hor_size,mpi_real4,             &
    1054. 

  1054.                              mpi_status_ignore, ierr)
    1055. 

  1055.         DO J=JTS,min(JTE,JDE-1)
    1056. 

  1056.          DO I=ITS,min(ITE,IDE-1)
    1057. 

  1057.            grid%e(I,J)=dumdata(I,J,1)
    1058. 

  1058.          ENDDO
    1059. 

  1059.         ENDDO
    1060. 

  1060. 

  1061.     varName='COSALPHA'
    1062. 

  1062.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1063. 

  1063.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1064. 

  1064.                              dumdata,hor_size,mpi_real4,             &
    1065. 

  1065.                              mpi_status_ignore, ierr)
    1066. 

  1066.         DO J=JTS,min(JTE,JDE-1)
    1067. 

  1067.          DO I=ITS,min(ITE,IDE-1)
    1068. 

  1068.            grid%cosa(I,J)=dumdata(I,J,1)
    1069. 

  1069.          ENDDO
    1070. 

  1070.         ENDDO
    1071. 

  1071. 

  1072.     varName='SINALPHA'
    1073. 

  1073.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1074. 

  1074.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1075. 

  1075.                              dumdata,hor_size,mpi_real4,             &
    1076. 

  1076.                              mpi_status_ignore, ierr)
    1077. 

  1077.         DO J=JTS,min(JTE,JDE-1)
    1078. 

  1078.          DO I=ITS,min(ITE,IDE-1)
    1079. 

  1079.            grid%sina(I,J)=dumdata(I,J,1)
    1080. 

  1080.          ENDDO
    1081. 

  1081.         ENDDO
    1082. 

  1082. 

  1083.     varName='MAPFAC_U'
    1084. 

  1084.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1085. 

  1085.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1086. 

  1086.                              dumdata_u,hor_size_u,mpi_real4,             &
    1087. 

  1087.                              mpi_status_ignore, ierr)
    1088. 

  1088.         DO J=JTS,min(JTE,JDE-1)
    1089. 

  1089.          DO I=ITS,min(ITE,IDE)
    1090. 

  1090.            grid%msfu(I,J)=dumdata_u(I,J,1)
    1091. 

  1091. 

  1092. !! bandaid for newly created WPS geogrid static files
    1093. 

  1093.         if (grid%msfu(I,J) .lt. 0.7) then
    1094. 

  1094.         write(0,*) 'weird msfu at I,J: ', I,J,grid%msfu(I,J)
    1095. 

  1095. 

  1096.         if(J .eq. min(JTE,JDE-1)) then
    1097. 

  1097.         grid%msfu(I,J)=dumdata_u(I,J-1,1)
    1098. 

  1098.         write(0,*) 'changing msfu to: ',I,J,  grid%msfu(I,J)
    1099. 

  1099.         endif
    1100. 

  1100.         
    1101. 

  1101.         endif
    1102. 

  1102. !! end bandaid 
    1103. 

  1103. 

  1104.          ENDDO
    1105. 

  1105.         ENDDO
    1106. 

  1106. 

  1107.     varName='MAPFAC_V'
    1108. 

  1108.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1109. 

  1109.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1110. 

  1110.                              dumdata_v,hor_size_v,mpi_real4,             &
    1111. 

  1111.                              mpi_status_ignore, ierr)
    1112. 

  1112.         DO J=JTS,min(JTE,JDE)
    1113. 

  1113.          DO I=ITS,min(ITE,IDE-1)
    1114. 

  1114.            grid%msfv(I,J)=dumdata_v(I,J,1)
    1115. 

  1115. 

  1116.         if (grid%msfv(I,J) .lt. 0.7 ) then
    1117. 

  1117.         write(0,*) 'weird msfv at I,J: ', I,J,grid%msfv(I,J)
    1118. 

  1118.         grid%msfv(I,J)=dumdata_v(I,J-1,1)
    1119. 

  1119.         if( J .eq. min(JTE,JDE)) then
    1120. 

  1120.         write(0,*) 'changing msfv to: ',I,J,  grid%msfv(I,J)
    1121. 

  1121.         endif
    1122. 

  1122. 

  1123.         endif
    1124. 

  1124. 

  1125.          ENDDO
    1126. 

  1126.         ENDDO
    1127. 

  1127. 

  1128.     varName='MAPFAC_M'
    1129. 

  1129.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1130. 

  1130.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1131. 

  1131.                              dumdata,hor_size,mpi_real4,             &
    1132. 

  1132.                              mpi_status_ignore, ierr)
    1133. 

  1133.         DO J=JTS,min(JTE,JDE-1)
    1134. 

  1134.          DO I=ITS,min(ITE,IDE-1)
    1135. 

  1135.            grid%msft(I,J)=dumdata(I,J,1)
    1136. 

  1136.          ENDDO
    1137. 

  1137.         ENDDO
    1138. 

  1138. 

  1139.     varName='CLAT'
    1140. 

  1140.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1141. 

  1141.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1142. 

  1142.                              dumdata,hor_size,mpi_real4,             &
    1143. 

  1143.                              mpi_status_ignore, ierr)
    1144. 

  1144.         DO J=JTS,min(JTE,JDE-1)
    1145. 

  1145.          DO I=ITS,min(ITE,IDE-1)
    1146. 

  1146.            grid%clat(I,J)=dumdata(I,J,1)
    1147. 

  1147.          ENDDO
    1148. 

  1148.         ENDDO
    1149. 

  1149. 

  1150.     varName='XLONG_U'
    1151. 

  1151.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1152. 

  1152.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1153. 

  1153.                              dumdata_u,hor_size_u,mpi_real4,             &
    1154. 

  1154.                              mpi_status_ignore, ierr)
    1155. 

  1155.         DO J=JTS,min(JTE,JDE-1)
    1156. 

  1156.          DO I=ITS,min(ITE,IDE)
    1157. 

  1157.            grid%xlong_u(I,J)=dumdata_u(I,J,1)
    1158. 

  1158.          ENDDO
    1159. 

  1159.         ENDDO
    1160. 

  1160. 

  1161.     varName='XLAT_U'
    1162. 

  1162.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1163. 

  1163.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1164. 

  1164.                              dumdata_u,hor_size_u,mpi_real4,             &
    1165. 

  1165.                              mpi_status_ignore, ierr)
    1166. 

  1166.         DO J=JTS,min(JTE,JDE-1)
    1167. 

  1167.          DO I=ITS,min(ITE,IDE)
    1168. 

  1168.            grid%xlat_u(I,J)=dumdata_u(I,J,1)
    1169. 

  1169.          ENDDO
    1170. 

  1170.         ENDDO
    1171. 

  1171. 

  1172.     varName='XLONG_V'
    1173. 

  1173.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1174. 

  1174.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1175. 

  1175.                              dumdata_v,hor_size_v,mpi_real4,             &
    1176. 

  1176.                              mpi_status_ignore, ierr)
    1177. 

  1177.         DO J=JTS,min(JTE,JDE)
    1178. 

  1178.          DO I=ITS,min(ITE,IDE-1)
    1179. 

  1179.            grid%xlong_v(I,J)=dumdata_v(I,J,1)
    1180. 

  1180.          ENDDO
    1181. 

  1181.         ENDDO
    1182. 

  1182. 

  1183.     varName='XLAT_V'
    1184. 

  1184.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1185. 

  1185.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1186. 

  1186.                              dumdata_v,hor_size_v,mpi_real4,             &
    1187. 

  1187.                              mpi_status_ignore, ierr)
    1188. 

  1188.         DO J=JTS,min(JTE,JDE)
    1189. 

  1189.          DO I=ITS,min(ITE,IDE-1)
    1190. 

  1190.            grid%xlat_v(I,J)=dumdata_v(I,J,1)
    1191. 

  1191.          ENDDO
    1192. 

  1192.         ENDDO
    1193. 

  1193. 

  1194.     varName='XLONG_M'
    1195. 

  1195.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1196. 

  1196.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1197. 

  1197.                              dumdata,hor_size,mpi_real4,             &
    1198. 

  1198.                              mpi_status_ignore, ierr)
    1199. 

  1199. 

  1200.         DO J=JTS,min(JTE,JDE-1)
    1201. 

  1201.          DO I=ITS,min(ITE,IDE-1)
    1202. 

  1202.            grid%xlong_gc(I,J)=dumdata(I,J,1)
    1203. 

  1203.          ENDDO
    1204. 

  1204.         ENDDO
    1205. 

  1205. 

  1206. 	write(0,*) 'reading XLAT_M'
    1207. 

  1207.     varName='XLAT_M'
    1208. 

  1208.     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
    1209. 

  1209.     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
    1210. 

  1210.                              dumdata,hor_size,mpi_real4,             &
    1211. 

  1211.                              mpi_status_ignore, ierr)
    1212. 

  1212. 

  1213.         DO J=JTS,min(JTE,JDE-1)
    1214. 

  1214.          DO I=ITS,min(ITE,IDE-1)
    1215. 

  1215.            grid%xlat_gc(I,J)=dumdata(I,J,1)
    1216. 

  1216.          ENDDO
    1217. 

  1217.         ENDDO
    1218. 

  1218. 	write(0,*) 'xlat_gc defined'
    1219. 

  1219. 

  1220.       call mpi_file_close(mpi_comm_world, ierr)
    1221. 

  1221. 

  1222. 	write(0,*) 'to ST000010 def'
    1223. 

  1223.        varName='ST000010'
    1224. 

  1224.        flag_st000010 = 1
    1225. 

  1225.        num_st_levels_input = num_st_levels_input + 1
    1226. 

  1226.        st_levels_input(num_st_levels_input) = char2int2(varName(3:8))
    1227. 

  1227.        DO J=JTS,min(JTE,JDE-1)
    1228. 

  1228.         DO I=ITS,min(ITE,IDE-1)
    1229. 

  1229.            st_input(I,num_st_levels_input + 1,J) = grid%st000010(i,j)
    1230. 

  1230.         ENDDO
    1231. 

  1231.        ENDDO
    1232. 

  1232. 	write(0,*) 'past ST000010 def'
    1233. 

  1233. 

  1234.        varName='ST010040'
    1235. 

  1235.        flag_st010040 = 1
    1236. 

  1236.        num_st_levels_input = num_st_levels_input + 1
    1237. 

  1237.        st_levels_input(num_st_levels_input) = char2int2(varName(3:8))
    1238. 

  1238.        DO J=JTS,min(JTE,JDE-1)
    1239. 

  1239.         DO I=ITS,min(ITE,IDE-1)
    1240. 

  1240.             st_input(I,num_st_levels_input + 1,J) = grid%st010040(i,j)
    1241. 

  1241.         ENDDO
    1242. 

  1242.        ENDDO
    1243. 

  1243. 

  1244.        varName='ST040100'
    1245. 

  1245.        flag_st040100 = 1
    1246. 

  1246.        num_st_levels_input = num_st_levels_input + 1
    1247. 

  1247.        st_levels_input(num_st_levels_input) = char2int2(varName(3:8))
    1248. 

  1248.        DO J=JTS,min(JTE,JDE-1)
    1249. 

  1249.         DO I=ITS,min(ITE,IDE-1)
    1250. 

  1250.               st_input(I,num_st_levels_input + 1,J) = grid%st040100(i,j)
    1251. 

  1251.         ENDDO
    1252. 

  1252.        ENDDO
    1253. 

  1253.  
    1254. 

  1254.        varName='ST100200'
    1255. 

  1255.        flag_st100200 = 1
    1256. 

  1256.        num_st_levels_input = num_st_levels_input + 1
    1257. 

  1257.        st_levels_input(num_st_levels_input) = char2int2(varName(3:8))
    1258. 

  1258.        DO J=JTS,min(JTE,JDE-1)
    1259. 

  1259.         DO I=ITS,min(ITE,IDE-1)
    1260. 

  1260.               st_input(I,num_st_levels_input + 1,J) = grid%st100200(i,j)
    1261. 

  1261.         ENDDO
    1262. 

  1262.        ENDDO
    1263. 

  1263. 

  1264.        varName='SM000010'
    1265. 

  1265.        flag_sm000010 = 1
    1266. 

  1266.        num_sm_levels_input = num_sm_levels_input + 1
    1267. 

  1267.        sm_levels_input(num_sm_levels_input) = char2int2(varName(3:8))
    1268. 

  1268.        DO J=JTS,min(JTE,JDE-1)
    1269. 

  1269.         DO I=ITS,min(ITE,IDE-1)
    1270. 

  1270.            sm_input(I,num_sm_levels_input + 1,J) = grid%sm000010(i,j)
    1271. 

  1271.         ENDDO
    1272. 

  1272.        ENDDO
    1273. 

  1273. 

  1274.        varName='SM010040'
    1275. 

  1275.        flag_sm010040 = 1
    1276. 

  1276.        num_sm_levels_input = num_sm_levels_input + 1
    1277. 

  1277.        sm_levels_input(num_sm_levels_input) = char2int2(varName(3:8))
    1278. 

  1278.        DO J=JTS,min(JTE,JDE-1)
    1279. 

  1279.         DO I=ITS,min(ITE,IDE-1)
    1280. 

  1280.             sm_input(I,num_sm_levels_input + 1,J) = grid%sm010040(i,j)
    1281. 

  1281.         ENDDO
    1282. 

  1282.        ENDDO
    1283. 

  1283. 

  1284.        varName='SM040100'
    1285. 

  1285.        flag_sm040100 = 1
    1286. 

  1286.        num_sm_levels_input = num_sm_levels_input + 1
    1287. 

  1287.        sm_levels_input(num_sm_levels_input) = char2int2(varName(3:8))
    1288. 

  1288.        DO J=JTS,min(JTE,JDE-1)
    1289. 

  1289.         DO I=ITS,min(ITE,IDE-1)
    1290. 

  1290.               sm_input(I,num_sm_levels_input + 1,J) = grid%sm040100(i,j)
    1291. 

  1291.         ENDDO
    1292. 

  1292.        ENDDO
    1293. 

  1293.  
    1294. 

  1294.        varName='SM100200'
    1295. 

  1295.        flag_sm100200 = 1
    1296. 

  1296.        num_sm_levels_input = num_sm_levels_input + 1
    1297. 

  1297.        sm_levels_input(num_sm_levels_input) = char2int2(varName(3:8))
    1298. 

  1298.        DO J=JTS,min(JTE,JDE-1)
    1299. 

  1299.         DO I=ITS,min(ITE,IDE-1)
    1300. 

  1300.               sm_input(I,num_sm_levels_input + 1,J) = grid%sm100200(i,j)
    1301. 

  1301.         ENDDO
    1302. 

  1302.        ENDDO
    1303. 

  1303. 

  1304. !           flag_sst = 1
    1305. 

  1305. 

  1306.         write(0,*) 'maxval st_input(1): ', maxval(st_input(:,1,:))
    1307. 

  1307.         write(0,*) 'maxval st_input(2): ', maxval(st_input(:,2,:))
    1308. 

  1308.         write(0,*) 'maxval st_input(3): ', maxval(st_input(:,3,:))
    1309. 

  1309.         write(0,*) 'maxval st_input(4): ', maxval(st_input(:,4,:))
    1310. 

  1310. 

  1311.         DEALLOCATE(pmsl)
    1312. 

  1312.         DEALLOCATE(psfc_in)
    1313. 

  1313.         DEALLOCATE(dumdata)
    1314. 

  1314.         DEALLOCATE(dumdata_u)
    1315. 

  1315.         DEALLOCATE(dumdata_v)
    1316. 

  1316. 

  1317. #endif
    1318. 

  1318.      end subroutine read_wps
    1319. 

  1319. 

  1320. ! -------------------------------------------------------------------------
    1321. 

  1321. ! -------------------------------------------------------------------------
    1322. 

  1322. 

  1323. !!!! MPI-IO pieces
    1324. 

  1324. 

  1325. subroutine retrieve_index(index,string,varname_all,nrecs,iret)
    1326. 

  1326. !$$$  subprogram documentation block
    1327. 

  1327. !                .      .    .                                       .
    1328. 

  1328. ! subprogram:    retrieve_index  get record number of desired variable
    1329. 

  1329. !   prgmmr: parrish          org: np22                date: 2004-11-29
    1330. 

  1330. !
    1331. 

  1331. ! abstract: by examining previously generated inventory of wrf binary restart file,
    1332. 

  1332. !             find record number that contains the header record for variable
    1333. 

  1333. !             identified by input character variable "string".
    1334. 

  1334. !
    1335. 

  1335. ! program history log:
    1336. 

  1336. !   2004-11-29  parrish
    1337. 

  1337. !
    1338. 

  1338. !   input argument list:
    1339. 

  1339. !     string           - mnemonic for variable desired
    1340. 

  1340. !     varname_all      - list of all mnemonics obtained from inventory of file
    1341. 

  1341. !     nrecs            - total number of sequential records counted in wrf
    1342. 

  1342. !                        binary restart file
    1343. 

  1343. !
    1344. 

  1344. !   output argument list:
    1345. 

  1345. !     index            - desired record number
    1346. 

  1346. !     iret             - return status, set to 0 if variable was found,
    1347. 

  1347. !                        non-zero if not.
    1348. 

  1348. !
    1349. 

  1349. ! attributes:
    1350. 

  1350. !   language: f90
    1351. 

  1351. !   machine:  ibm RS/6000 SP
    1352. 

  1352. !
    1353. 

  1353. !$$$
    1354. 

  1354. 

  1355.   implicit none
    1356. 

  1356. 

  1357.   integer,intent(out)::iret
    1358. 

  1358.   integer,intent(in)::nrecs
    1359. 

  1359.   integer,intent(out):: index
    1360. 

  1360.   character(*), intent(in):: string
    1361. 

  1361.   character(132),intent(in)::varname_all(nrecs)
    1362. 

  1362. 

  1363.   integer i
    1364. 

  1364. 

  1365.   iret=0
    1366. 

  1366. 

  1367.   do i=1,nrecs
    1368. 

  1368.    if(trim(string) == trim(varname_all(i))) then
    1369. 

  1369.       index=i
    1370. 

  1370.       return
    1371. 

  1371.    end if
    1372. 

  1372.   end do
    1373. 

  1373. 

  1374.   write(6,*)' problem reading wrf nmm binary file, rec id "',trim(string),'" not found'
    1375. 

  1375. 

  1376.   iret=-1
    1377. 

  1377. 

  1378. end subroutine retrieve_index
    1379. 

  1379. subroutine next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
    1380. 

  1380. !$$$  subprogram documentation block
    1381. 

  1381. !                .      .    .                                       .
    1382. 

  1382. ! subprogram:    next_buf    bring in next direct access block
    1383. 

  1383. !   prgmmr: parrish          org: np22                date: 2004-11-29
    1384. 

  1384. !
    1385. 

  1385. ! abstract: bring in next direct access block when needed, as the file is scanned
    1386. 

  1386. !             from beginning to end during counting and inventory of records.
    1387. 

  1387. !             (subroutines count_recs_wrf_binary_file and inventory_wrf_binary_file)
    1388. 

  1388. !
    1389. 

  1389. ! program history log:
    1390. 

  1390. !   2004-11-29  parrish
    1391. 

  1391. !
    1392. 

  1392. !   input argument list:
    1393. 

  1393. !     in_unit          - fortran unit number where input file is opened through.
    1394. 

  1394. !     nextbyte         - byte number from beginning of file that is desired
    1395. 

  1395. !     locbyte          - byte number from beginning of last block read for desired byt
    1396. 

  1396. !     lrecl            - direct access block length
    1397. 

  1397. !     nreads           - number of blocks read before now (for diagnostic information
    1398. 

  1398. !     lastbuf          - logical, if true, then no more blocks, so return
    1399. 

  1399. !
    1400. 

  1400. !   output argument list:
    1401. 

  1401. !     buf              - output array containing contents of next block
    1402. 

  1402. !     locbyte          - byte number from beginning of new block read for desired byte
    1403. 

  1403. !     thisblock        - number of new block being read by this routine
    1404. 

  1404. !     nreads           - number of blocks read now (for diagnostic information only)
    1405. 

  1405. !     lastbuf          - logical, if true, then at end of file.
    1406. 

  1406. !
    1407. 

  1407. ! attributes:
    1408. 

  1408. !   language: f90
    1409. 

  1409. !   machine:  ibm RS/6000 SP
    1410. 

  1410. !
    1411. 

  1411. !$$$
    1412. 

  1412. !  use kinds, only: i_byte,i_llong
    1413. 

  1413.   implicit none
    1414. 

  1414. 

  1415.   integer(i_llong) lrecl
    1416. 

  1416.   integer in_unit,nreads
    1417. 

  1417.   integer(i_byte) buf(lrecl)
    1418. 

  1418.   integer(i_llong) nextbyte,locbyte,thisblock
    1419. 

  1419.   logical lastbuf
    1420. 

  1420. 

  1421.   integer ierr
    1422. 

  1422. 

  1423.   if(lastbuf) return
    1424. 

  1424. 

  1425.   ierr=0
    1426. 

  1426.   nreads=nreads+1
    1427. 

  1427. 

  1428. !  compute thisblock:
    1429. 

  1429. 

  1430.   thisblock = 1_i_llong + (nextbyte-1_i_llong)/lrecl
    1431. 

  1431. 

  1432.   locbyte = 1_i_llong+mod(locbyte-1_i_llong,lrecl)
    1433. 

  1433. 

  1434.   read(in_unit,rec=thisblock,iostat=ierr)buf
    1435. 

  1435.   lastbuf = ierr /= 0
    1436. 

  1436. 

  1437. end subroutine next_buf
    1438. 

  1438. 

  1439. subroutine inventory_wrf_binary_file(in_unit,wrf_ges_filename,nrecs, &
    1440. 

  1440.                                      datestr_all,varname_all,domainend_all, &
    1441. 

  1441.                                      start_block,end_block,start_byte,end_byte,file_offset)
    1442. 

  1442. !$$$  subprogram documentation block
    1443. 

  1443. !                .      .    .                                       .
    1444. 

  1444. ! subprogram:    inventory_wrf_binary_file  get contents of wrf binary file
    1445. 

  1445. !   prgmmr: parrish          org: np22                date: 2004-11-29
    1446. 

  1446. !
    1447. 

  1447. ! abstract: generate list of contents and map of wrf binary file which can be
    1448. 

  1448. !             used for reading and writing with mpi io routines.
    1449. 

  1449. !             same basic routine as count_recs_wrf_binary_file, except
    1450. 

  1450. !             now wrf unpacking routines are used to decode wrf header
    1451. 

  1451. !             records, and send back lists of variable mnemonics, dates,
    1452. 

  1452. !             grid dimensions, and byte addresses relative to start of
    1453. 

  1453. !             file for each field (this is used by mpi io routines).
    1454. 

  1454. !
    1455. 

  1455. ! program history log:
    1456. 

  1456. !   2004-11-29  parrish
    1457. 

  1457. !
    1458. 

  1458. !
    1459. 

  1459. !   input argument list:
    1460. 

  1460. !     in_unit          - fortran unit number where input file is opened through.
    1461. 

  1461. !     wrf_ges_filename - filename of input wrf binary restart file
    1462. 

  1462. !     nrecs            - number of sequential records found on input wrf binary restart file.
    1463. 

  1463. !                          (obtained by a previous call to count_recs_wrf_binary_file)
    1464. 

  1464. !
    1465. 

  1465. !   output argument list:  (all following dimensioned nrecs)
    1466. 

  1466. !     datestr_all      - date character string for each field, where applicable (or else blanks)
    1467. 

  1467. !     varname_all      - wrf mnemonic for each variable, where applicable (or blank)
    1468. 

  1468. !     domainend_all    - dimensions of each field, where applicable (up to 3 dimensions)
    1469. 

  1469. !     start_block      - direct access block number containing 1st byte of record
    1470. 

  1470. !                            (after 4 byte record mark)
    1471. 

  1471. !     end_block        - direct access block number containing last byte of record
    1472. 

  1472. !                            (before 4 byte record mark)
    1473. 

  1473. !     start_byte       - relative byte address in direct access block of 1st byte of record
    1474. 

  1474. !     end_byte         - relative byte address in direct access block of last byte of record
    1475. 

  1475. !     file_offset      - absolute address of byte before 1st byte of record (used by mpi io)
    1476. 

  1476. !
    1477. 

  1477. ! attributes:
    1478. 

  1478. !   language: f90
    1479. 

  1479. !   machine:  ibm RS/6000 SP
    1480. 

  1480. !
    1481. 

  1481. !$$$
    1482. 

  1482. !   use kinds, only: r_single,i_byte,i_long,i_llong
    1483. 

  1483.   use module_internal_header_util
    1484. 

  1484.   implicit none
    1485. 

  1485. 

  1486.   integer,intent(in)::in_unit,nrecs
    1487. 

  1487.   character(*),intent(in)::wrf_ges_filename
    1488. 

  1488.   character(132),intent(out)::datestr_all(nrecs),varname_all(nrecs)
    1489. 

  1489.   integer,intent(out)::domainend_all(3,nrecs)
    1490. 

  1490.   integer,intent(out)::start_block(nrecs),end_block(nrecs)
    1491. 

  1491.   integer,intent(out)::start_byte(nrecs),end_byte(nrecs)
    1492. 

  1492.   integer(i_llong),intent(out)::file_offset(nrecs)
    1493. 

  1493. 

  1494.   integer irecs
    1495. 

  1495.   integer(i_llong) nextbyte,locbyte,thisblock
    1496. 

  1496.   integer(i_byte) lenrec4(4)
    1497. 

  1497.   integer(i_long) lenrec,lensave
    1498. 

  1498.   equivalence (lenrec4(1),lenrec)
    1499. 

  1499.   integer(i_byte) missing4(4)
    1500. 

  1500.   integer(i_long) missing
    1501. 

  1501.   equivalence (missing,missing4(1))
    1502. 

  1502.   integer(i_llong),parameter:: lrecl=2**20
    1503. 

  1503.   integer(i_byte) buf(lrecl)
    1504. 

  1504.   integer i,loc_count,nreads
    1505. 

  1505.   logical lastbuf
    1506. 

  1506.   integer(i_byte) hdrbuf4(2048)
    1507. 

  1507.   integer(i_long) hdrbuf(512)
    1508. 

  1508.   equivalence(hdrbuf(1),hdrbuf4(1))
    1509. 

  1509.   integer,parameter:: int_field       =       530
    1510. 

  1510.   integer,parameter:: int_dom_ti_char =       220
    1511. 

  1511.   integer,parameter:: int_dom_ti_real =       140
    1512. 

  1512.   integer,parameter:: int_dom_ti_integer =       180
    1513. 

  1513.   integer hdrbufsize
    1514. 

  1514.   integer inttypesize
    1515. 

  1515.   integer datahandle,count
    1516. 

  1516.   character(128) element,dumstr,strdata
    1517. 

  1517.   integer loccode
    1518. 

  1518.   character(132) blanks
    1519. 

  1519.   integer typesize
    1520. 

  1520.   integer fieldtype,comm,iocomm
    1521. 

  1521.   integer domaindesc
    1522. 

  1522.   character(132) memoryorder,stagger,dimnames(3)
    1523. 

  1523.   integer domainstart(3),domainend(3)
    1524. 

  1524.   integer memorystart(3),memoryend(3)
    1525. 

  1525.   integer patchstart(3),patchend(3)
    1526. 

  1526.   character(132) datestr,varname
    1527. 

  1527.   real dummy_field(1)
    1528. 

  1528. !  real(r_single) dummy_field(1)
    1529. 

  1529. !  integer dummy_field
    1530. 

  1530. !  real dummy_field
    1531. 

  1531.   integer itypesize
    1532. 

  1532.   integer idata(1)
    1533. 

  1533.   real rdata(1)
    1534. 

  1534. 

  1535.   call wrf_sizeof_integer(itypesize)
    1536. 

  1536.   inttypesize=itypesize
    1537. 

  1537. 

  1538.   blanks=trim(' ')
    1539. 

  1539. 

  1540. 	write(0,*) 'inventory subroutine'
    1541. 

  1541. 

  1542. 	write(0,*) 'opening file : ', trim(wrf_ges_filename)
    1543. 

  1543. 

  1544.   open(in_unit,file=trim(wrf_ges_filename),access='direct',recl=lrecl)
    1545. 

  1545.   irecs=0
    1546. 

  1546.   missing=-9999
    1547. 

  1547.   nextbyte=0_i_llong
    1548. 

  1548.   locbyte=lrecl
    1549. 

  1549.   nreads=0
    1550. 

  1550.   lastbuf=.false.
    1551. 

  1551.   do
    1552. 

  1552. 

  1553. !   get length of next record
    1554. 

  1554. 

  1555.     do i=1,4
    1556. 

  1556.      nextbyte=nextbyte+1_i_llong
    1557. 

  1557.      locbyte=locbyte+1_i_llong
    1558. 

  1558.      if(locbyte > lrecl .and. lastbuf) go to 900
    1559. 

  1559.      if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
    1560. 

  1560.      lenrec4(i)=buf(locbyte)
    1561. 

  1561.     end do
    1562. 

  1562.     if(lenrec <= 0 .and. lastbuf) go to 900
    1563. 

  1563.     if(lenrec <= 0 .and. .not. lastbuf) go to 885
    1564. 

  1564.     nextbyte=nextbyte+1_i_llong
    1565. 

  1565.     locbyte=locbyte+1_i_llong
    1566. 

  1566.     if(locbyte > lrecl .and. lastbuf) go to 900
    1567. 

  1567.     if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
    1568. 

  1568. 

  1569.     irecs=irecs+1
    1570. 

  1570.     start_block(irecs)=thisblock
    1571. 

  1571.     start_byte(irecs)=locbyte
    1572. 

  1572.     file_offset(irecs)=nextbyte-1_i_llong
    1573. 

  1573.     hdrbuf4(1)=buf(locbyte)
    1574. 

  1574.     hdrbuf4(2:4)=missing4(2:4)
    1575. 

  1575.     hdrbuf4(5:8)=missing4(1:4)
    1576. 

  1576.     datestr_all(irecs)=blanks
    1577. 

  1577.     varname_all(irecs)=blanks
    1578. 

  1578.     domainend_all(1:3,irecs)=0
    1579. 

  1579. 

  1580.     loc_count=1
    1581. 

  1581. !	write(0,*) '1, hdrbuf4(1): 1', hdrbuf4(1) 
    1582. 

  1582.     do i=2,8
    1583. 

  1583.        if(loc_count.ge.lenrec) exit
    1584. 

  1584.        loc_count=loc_count+1
    1585. 

  1585.        nextbyte=nextbyte+1_i_llong
    1586. 

  1586.        locbyte=locbyte+1_i_llong
    1587. 

  1587.        if(locbyte > lrecl .and. lastbuf) go to 900
    1588. 

  1588.        if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
    1589. 

  1589.        hdrbuf4(i)=buf(locbyte)
    1590. 

  1590. !	write(0,*) 'I, hdrbuf4(I): ', I, hdrbuf4(I)
    1591. 

  1591.     end do
    1592. 

  1592. 

  1593. !         if(lenrec==2048) write(0,*)' irecs,hdrbuf(2),int_dom_ti_char,int_field=', &
    1594. 

  1594. !                                      irecs,hdrbuf(2),int_dom_ti_char,int_field, int_dom_ti_real, int_dom_ti_integer
    1595. 

  1595. 	
    1596. 

  1596.     if(lenrec==2048.and.(hdrbuf(2) == int_dom_ti_char .or. hdrbuf(2) == int_field &
    1597. 

  1597.     .or. hdrbuf(2) == int_dom_ti_real .or. hdrbuf(2) == int_dom_ti_integer)) then
    1598. 

  1598. 

  1599. !    bring in next full record, so we can unpack datestr, varname, and domainend
    1600. 

  1600.        do i=9,lenrec
    1601. 

  1601.           loc_count=loc_count+1
    1602. 

  1602.           nextbyte=nextbyte+1_i_llong
    1603. 

  1603.           locbyte=locbyte+1_i_llong
    1604. 

  1604.           if(locbyte > lrecl .and. lastbuf) go to 900
    1605. 

  1605.           if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
    1606. 

  1606.           hdrbuf4(i)=buf(locbyte)
    1607. 

  1607. !	write(0,*) 'I, hdrbuf4(I): ', I, hdrbuf4(I)
    1608. 

  1608.        end do
    1609. 

  1609. !	write(0,*) 'past 9,lenrec loop'
    1610. 

  1610. !	write(0,*) 'hdrbuf(2): ', hdrbuf(2) 
    1611. 

  1611. 

  1612.        if(hdrbuf(2) == int_dom_ti_char) then
    1613. 

  1613. 

  1614.           call int_get_ti_header_char(hdrbuf,hdrbufsize,inttypesize, &
    1615. 

  1615.                    datahandle,element,dumstr,strdata,loccode)
    1616. 

  1616.           varname_all(irecs)=trim(element)
    1617. 

  1617.           datestr_all(irecs)=trim(strdata)
    1618. 

  1618.               write(0,*)'(1) irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),trim(datestr_all(irecs))
    1619. 

  1619. 

  1620.        else if(hdrbuf(2) == int_dom_ti_real) then
    1621. 

  1621. 

  1622. !	write(0,*) 'call int_get_ti_header_real'
    1623. 

  1623. 

  1624. !	write(0,*) 'hdrbuf(1:10): ', hdrbuf(1:10)
    1625. 

  1625. 

  1626. !	write(0,*) 'call with inttypesize typesize: ', inttypesize,typesize
    1627. 

  1627. 

  1628.           call int_get_ti_header_real(hdrbuf,hdrbufsize,inttypesize,typesize, &
    1629. 

  1629.                    datahandle,element,rdata,count,loccode)
    1630. 

  1630. 

  1631. !	write(0,*) 'return int_get_ti_header_real'
    1632. 

  1632. 

  1633.           varname_all(irecs)=trim(element)
    1634. 

  1634. 

  1635. !	write(0,*) 'varname_all(irecs): ', varname_all(irecs)
    1636. 

  1636. 

  1637. !          datestr_all(irecs)=trim(strdata)
    1638. 

  1638. 

  1639.               write(0,*)'(2) irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),rdata(1)
    1640. 

  1640. !	write(0,*) ' --------------------------- '
    1641. 

  1641.          
    1642. 

  1642.        else if(hdrbuf(2) == int_dom_ti_integer) then
    1643. 

  1643. 

  1644.           call int_get_ti_header_integer(hdrbuf,hdrbufsize,inttypesize,typesize, &
    1645. 

  1645.                    datahandle,element,idata,count,loccode)
    1646. 

  1646.           varname_all(irecs)=trim(element)
    1647. 

  1647. !          datestr_all(irecs)=trim(strdata)
    1648. 

  1648.               write(0,*)'(3) irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),idata(1:count)
    1649. 

  1649. 

  1650.        else
    1651. 

  1651. 

  1652. !	write(0,*) 'call int_get_write_field_header'
    1653. 

  1653.           call int_get_write_field_header(hdrbuf,hdrbufsize,inttypesize,typesize, &
    1654. 

  1654.              datahandle,datestr,varname,dummy_field,fieldtype,comm,iocomm, &
    1655. 

  1655.              domaindesc,memoryorder,stagger,dimnames, &
    1656. 

  1656.              domainstart,domainend,memorystart,memoryend,patchstart,patchend)
    1657. 

  1657.           varname_all(irecs)=trim(varname)
    1658. 

  1658.           datestr_all(irecs)=trim(datestr)
    1659. 

  1659.           domainend_all(1:3,irecs)=domainend(1:3)
    1660. 

  1660. !              write(0,*)'(4) irecs,datestr,domend,varname = ', &
    1661. 

  1661. !                  irecs,trim(datestr_all(irecs)),domainend_all(1:3,irecs),trim(varname_all(irecs))
    1662. 

  1662. 

  1663.        end if
    1664. 

  1664.     end if
    1665. 

  1665. 

  1666.     nextbyte=nextbyte-loc_count+lenrec
    1667. 

  1667.     locbyte=locbyte-loc_count+lenrec
    1668. 

  1668.     if(locbyte > lrecl .and. lastbuf) go to 900
    1669. 

  1669.     if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
    1670. 

  1670.     end_block(irecs)=thisblock
    1671. 

  1671.     end_byte(irecs)=locbyte
    1672. 

  1672.     lensave=lenrec
    1673. 

  1673.     do i=1,4
    1674. 

  1674.      nextbyte=nextbyte+1_i_llong
    1675. 

  1675.      locbyte=locbyte+1_i_llong
    1676. 

  1676.      if(locbyte > lrecl .and. lastbuf) go to 900
    1677. 

  1677.      if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
    1678. 

  1678.      lenrec4(i)=buf(locbyte)
    1679. 

  1679.     end do
    1680. 

  1680.     if(lenrec /= lensave) go to 890
    1681. 

  1681. 

  1682.   end do
    1683. 

  1683. 

  1684. 880  continue
    1685. 

  1685.      write(6,*)' reached impossible place in inventory_wrf_binary_file'
    1686. 

  1686.      close(in_unit)
    1687. 

  1687.      return
    1688. 

  1688. 

  1689. 885  continue
    1690. 

  1690.      write(0,*)' problem in inventory_wrf_binary_file, lenrec has bad value before end of file'
    1691. 

  1691.      write(0,*)'     lenrec =',lenrec
    1692. 

  1692.      close(in_unit)
    1693. 

  1693.      return
    1694. 

  1694. 

  1695. 890  continue
    1696. 

  1696.      write(0,*)' problem in inventory_wrf_binary_file, beginning and ending rec len words unequal'
    1697. 

  1697.      write(0,*)'     begining reclen =',lensave
    1698. 

  1698.      write(0,*)'       ending reclen =',lenrec
    1699. 

  1699.      write(0,*)'               irecs =',irecs
    1700. 

  1700.      write(0,*)'               nrecs =',nrecs
    1701. 

  1701.      call wrf_error_fatal("curious reclen discrepancy")
    1702. 

  1702.      close(in_unit)
    1703. 

  1703.      return
    1704. 

  1704. 

  1705. 900  continue
    1706. 

  1706.      write(0,*)' normal end of file reached in inventory_wrf_binary_file'
    1707. 

  1707.      write(0,*)'        nblocks=',thisblock
    1708. 

  1708.      write(0,*)'          irecs,nrecs=',irecs,nrecs
    1709. 

  1709.      write(0,*)'         nreads=',nreads
    1710. 

  1710.      close(in_unit)
    1711. 

  1711. 

  1712. end subroutine inventory_wrf_binary_file
    1713. 

  1713. 

  1714. SUBROUTINE wrf_sizeof_integer( retval )
    1715. 

  1715.   IMPLICIT NONE
    1716. 

  1716.   INTEGER retval
    1717. 

  1717. ! 4 is defined by CPP
    1718. 

  1718.   retval = 4
    1719. 

  1719.   RETURN
    1720. 

  1720. END SUBROUTINE wrf_sizeof_integer
    1721. 

  1721. 

  1722. SUBROUTINE wrf_sizeof_real( retval )
    1723. 

  1723.   IMPLICIT NONE
    1724. 

  1724.   INTEGER retval
    1725. 

  1725. ! 4 is defined by CPP
    1726. 

  1726.   retval = 4
    1727. 

  1727.   RETURN
    1728. 

  1728. END SUBROUTINE wrf_sizeof_real
    1729. 

  1729. 

  1730. !!!
    1731. 

  1731. !!!
    1732. 

  1732. !!!
    1733. 

  1733. 

  1734. subroutine count_recs_wrf_binary_file(in_unit,wrf_ges_filename,nrecs)
    1735. 

  1735. !$$$  subprogram documentation block
    1736. 

  1736. !                .      .    .                                       .
    1737. 

  1737. ! subprogram:    count_recs_binary_file  count # recs on wrf binary file
    1738. 

  1738. !   prgmmr: parrish          org: np22                date: 2004-11-29
    1739. 

  1739. !
    1740. 

  1740. ! abstract: count number of sequential records contained in wrf binary
    1741. 

  1741. !             file.  this is done by opening the file in direct access
    1742. 

  1742. !             mode with block length of 2**20, the size of the physical
    1743. 

  1743. !             blocks on ibm "blue" and "white" machines.  for optimal
    1744. 

  1744. !             performance, change block length to correspond to the
    1745. 

  1745. !             physical block length of host machine disk space.
    1746. 

  1746. !             records are counted by looking for the 4 byte starting
    1747. 

  1747. !             and ending sequential record markers, which contain the
    1748. 

  1748. !             record size in bytes.  only blocks are read which are known
    1749. 

  1749. !             by simple calculation to contain these record markers.
    1750. 

  1750. !             even though this is done on one processor, it is still
    1751. 

  1751. !             very fast, and the time will always scale by the number of
    1752. 

  1752. !             sequential records, not their size.  this step and the
    1753. 

  1753. !             following inventory step consistently take less than 0.1 seconds
    1754. 

  1754. !             to complete.
    1755. 

  1755. !
    1756. 

  1756. ! program history log:
    1757. 

  1757. !   2004-11-29  parrish
    1758. 

  1758. !
    1759. 

  1759. !   input argument list:
    1760. 

  1760. !     in_unit          - fortran unit number where input file is opened through.
    1761. 

  1761. !     wrf_ges_filename - filename of input wrf binary restart file
    1762. 

  1762. !
    1763. 

  1763. !   output argument list:
    1764. 

  1764. !     nrecs            - number of sequential records found on input wrf binary restart fil
    1765. 

  1765. !
    1766. 

  1766. ! attributes:
    1767. 

  1767. !   language: f90
    1768. 

  1768. !   machine:  ibm RS/6000 SP
    1769. 

  1769. !
    1770. 

  1770. !$$$
    1771. 

  1771. 

  1772. !   do an initial read through of a wrf binary file, and get total number of sequential fil
    1773. 

  1773. 

  1774. !   use kinds, only: r_single,i_byte,i_long,i_llong
    1775. 

  1775.   implicit none
    1776. 

  1776. 

  1777.   integer,intent(in)::in_unit
    1778. 

  1778.   character(*),intent(in)::wrf_ges_filename
    1779. 

  1779.   integer,intent(out)::nrecs
    1780. 

  1780. 

  1781.   integer(i_llong) nextbyte,locbyte,thisblock
    1782. 

  1782.   integer(i_byte) lenrec4(4)
    1783. 

  1783.   integer(i_long) lenrec,lensave
    1784. 

  1784.   equivalence (lenrec4(1),lenrec)
    1785. 

  1785.   integer(i_byte) missing4(4)
    1786. 

  1786.   integer(i_long) missing
    1787. 

  1787.   equivalence (missing,missing4(1))
    1788. 

  1788.   integer(i_llong),parameter:: lrecl=2**20
    1789. 

  1789.   integer(i_byte) buf(lrecl)
    1790. 

  1790.   integer i,loc_count,nreads
    1791. 

  1791.   logical lastbuf
    1792. 

  1792. 

  1793.   open(in_unit,file=trim(wrf_ges_filename),access='direct',recl=lrecl)
    1794. 

  1794.   nrecs=0
    1795. 

  1795.   missing=-9999
    1796. 

  1796.   nextbyte=0_i_llong
    1797. 

  1797.   locbyte=lrecl
    1798. 

  1798.   nreads=0
    1799. 

  1799.   lastbuf=.false.
    1800. 

  1800.   do
    1801. 

  1801. 

  1802. !   get length of next record
    1803. 

  1803. 

  1804.     do i=1,4
    1805. 

  1805.      nextbyte=nextbyte+1_i_llong
    1806. 

  1806.      locbyte=locbyte+1_i_llong
    1807. 

  1807.      if(locbyte > lrecl .and. lastbuf) go to 900
    1808. 

  1808.      if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
    1809. 

  1809.      lenrec4(i)=buf(locbyte)
    1810. 

  1810.     end do
    1811. 

  1811.     if(lenrec <= 0 .and. lastbuf) go to 900
    1812. 

  1812.     if(lenrec <= 0 .and. .not.lastbuf) go to 885
    1813. 

  1813.     nextbyte=nextbyte+1_i_llong
    1814. 

  1814.     locbyte=locbyte+1_i_llong
    1815. 

  1815.     if(locbyte > lrecl .and. lastbuf) go to 900
    1816. 

  1816.     if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
    1817. 

  1817. 

  1818.     nrecs=nrecs+1
    1819. 

  1819. 

  1820.     loc_count=1
    1821. 

  1821.     do i=2,4
    1822. 

  1822.        if(loc_count.ge.lenrec) exit
    1823. 

  1823.        loc_count=loc_count+1
    1824. 

  1824.        nextbyte=nextbyte+1_i_llong
    1825. 

  1825.        locbyte=locbyte+1_i_llong
    1826. 

  1826.        if(locbyte > lrecl .and. lastbuf) go to 900
    1827. 

  1827.        if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
    1828. 

  1828.     end do
    1829. 

  1829.     do i=1,4
    1830. 

  1830.        if(loc_count.ge.lenrec) exit
    1831. 

  1831.        loc_count=loc_count+1
    1832. 

  1832.        nextbyte=nextbyte+1_i_llong
    1833. 

  1833.        locbyte=locbyte+1_i_llong
    1834. 

  1834.        if(locbyte > lrecl .and. lastbuf) go to 900
    1835. 

  1835.        if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
    1836. 

  1836.     end do
    1837. 

  1837.     nextbyte=nextbyte-loc_count+lenrec
    1838. 

  1838.     locbyte=locbyte-loc_count+lenrec
    1839. 

  1839.     if(locbyte > lrecl .and. lastbuf) go to 900
    1840. 

  1840.     if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
    1841. 

  1841.     lensave=lenrec
    1842. 

  1842.     do i=1,4
    1843. 

  1843.      nextbyte=nextbyte+1_i_llong
    1844. 

  1844.      locbyte=locbyte+1_i_llong
    1845. 

  1845.      if(locbyte > lrecl .and. lastbuf) go to 900
    1846. 

  1846.      if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
    1847. 

  1847.      lenrec4(i)=buf(locbyte)
    1848. 

  1848.     end do
    1849. 

  1849.     if(lenrec /= lensave) go to 890
    1850. 

  1850. 

  1851.   end do
    1852. 

  1852. 

  1853. 880  continue
    1854. 

  1854.      write(6,*)' reached impossible place in count_recs_wrf_binary_file'
    1855. 

  1855.      close(in_unit)
    1856. 

  1856.      return
    1857. 

  1857. 

  1858. 885  continue
    1859. 

  1859.      write(6,*)' problem in count_recs_wrf_binary_file, lenrec has bad value before end of file'
    1860. 

  1860.      write(6,*)'     lenrec =',lenrec
    1861. 

  1861.      close(in_unit)
    1862. 

  1862.      return
    1863. 

  1863. 

  1864. 890  continue
    1865. 

  1865.      write(6,*)' problem in count_recs_wrf_binary_file, beginning and ending rec len words unequal'
    1866. 

  1866.      write(6,*)'     begining reclen =',lensave
    1867. 

  1867.      write(6,*)'       ending reclen =',lenrec
    1868. 

  1868.      close(in_unit)
    1869. 

  1869.      call wrf_error_fatal("bad reclen stuff")
    1870. 

  1870.      return
    1871. 

  1871. 

  1872. 900  continue
    1873. 

  1873.      write(6,*)' normal end of file reached in count_recs_wrf_binary_file'
    1874. 

  1874.      write(6,*)'        nblocks=',thisblock
    1875. 

  1875.      write(6,*)'          nrecs=',nrecs
    1876. 

  1876.      write(6,*)'         nreads=',nreads
    1877. 

  1877.      close(in_unit)
    1878. 

  1878. 

  1879. end subroutine count_recs_wrf_binary_file
    1880. 

  1880. 

  1881. subroutine retrieve_field(in_unit,wrfges,out,start_block,end_block,start_byte,end_byte)
    1882. 

  1882. !$$$  subprogram documentation block
    1883. 

  1883. !                .      .    .                                       .
    1884. 

  1884. ! subprogram:    retrieve_field  retrieve field from wrf binary file
    1885. 

  1885. !   prgmmr: parrish          org: np22                date: 2004-11-29
    1886. 

  1886. !
    1887. 

  1887. ! abstract: still using direct access, retrieve a field from the wrf binary restart file.
    1888. 

  1888. !
    1889. 

  1889. ! program history log:
    1890. 

  1890. !   2004-11-29  parrish
    1891. 

  1891. !
    1892. 

  1892. !   input argument list:
    1893. 

  1893. !     in_unit          - fortran unit number where input file is opened through.
    1894. 

  1894. !     wrfges - filename of input wrf binary restart file
    1895. 

  1895. !     start_block      - direct access block number containing 1st byte of record
    1896. 

  1896. !                            (after 4 byte record mark)
    1897. 

  1897. !     end_block        - direct access block number containing last byte of record
    1898. 

  1898. !                            (before 4 byte record mark)
    1899. 

  1899. !     start_byte       - relative byte address in direct access block of 1st byte of record
    1900. 

  1900. !     end_byte         - relative byte address in direct access block of last byte of record
    1901. 

  1901. !
    1902. 

  1902. !   output argument list:
    1903. 

  1903. !     out              - output buffer where desired field is deposited
    1904. 

  1904. !
    1905. 

  1905. ! attributes:
    1906. 

  1906. !   language: f90
    1907. 

  1907. !   machine:  ibm RS/6000 SP
    1908. 

  1908. !
    1909. 

  1909. !$$$
    1910. 

  1910. 

  1911.  ! use kinds, only: i_byte,i_kind
    1912. 

  1912.   implicit none
    1913. 

  1913. 

  1914.   integer(i_kind),intent(in)::in_unit
    1915. 

  1915.   character(50),intent(in)::wrfges
    1916. 

  1916.   integer(i_kind),intent(in)::start_block,end_block,start_byte,end_byte
    1917. 

  1917.   integer(i_byte),intent(out)::out(*)
    1918. 

  1918. 

  1919.   integer(i_llong),parameter:: lrecl=2**20
    1920. 

  1920.   integer(i_byte) buf(lrecl)
    1921. 

  1921.   integer(i_kind) i,ii,k
    1922. 

  1922.   integer(i_llong) ibegin,iend,ierr
    1923. 

  1923. 

  1924.   open(in_unit,file=trim(wrfges),access='direct',recl=lrecl)
    1925. 

  1925. 

  1926.      write(6,*)' in retrieve_field, start_block,end_block=',start_block,end_block
    1927. 

  1927.      write(6,*)' in retrieve_field, start_byte,end_byte=',start_byte,end_byte
    1928. 

  1928.   ii=0
    1929. 

  1929.   do k=start_block,end_block
    1930. 

  1930.      read(in_unit,rec=k,iostat=ierr)buf
    1931. 

  1931.      ibegin=1 ; iend=lrecl
    1932. 

  1932.      if(k == start_block) ibegin=start_byte
    1933. 

  1933.      if(k == end_block) iend=end_byte
    1934. 

  1934.      do i=ibegin,iend
    1935. 

  1935.         ii=ii+1
    1936. 

  1936.         out(ii)=buf(i)
    1937. 

  1937.      end do
    1938. 

  1938.   end do
    1939. 

  1939.   close(in_unit)
    1940. 

  1940. 

  1941. end subroutine retrieve_field
    1942. 

  1942. 

  1943. 

  1944. END MODULE module_wps_io_arw
    1945. 

  1945.