PageRenderTime 67ms CodeModel.GetById 27ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/share/module_optional_input.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 1429 lines | 1061 code | 230 blank | 138 comment | 49 complexity | bcd63b7c2a7d3e3522b1b85029bc0a17 MD5 | raw file
Possible License(s): AGPL-1.0

Large files files are truncated, but you can click here to view the full file

  1. MODULE module_optional_input
  2. INTEGER :: flag_metgrid , flag_tavgsfc , flag_psfc , flag_soilhgt , flag_mf_xy , flag_slp , &
  3. flag_snow , flag_snowh , flag_tsk , flag_pinterp
  4. INTEGER :: flag_qv , flag_qc , flag_qr , flag_qi , flag_qs , &
  5. flag_qg , flag_qh , flag_qni , flag_sh
  6. INTEGER :: flag_soil_levels, flag_soil_layers
  7. INTEGER :: flag_st000010 , flag_st010040 , flag_st040100 , flag_st100200 , flag_st010200 , &
  8. flag_sm000010 , flag_sm010040 , flag_sm040100 , flag_sm100200 , flag_sm010200 , &
  9. flag_sw000010 , flag_sw010040 , flag_sw040100 , flag_sw100200 , flag_sw010200
  10. INTEGER :: flag_st000007 , flag_st007028 , flag_st028100 , flag_st100255 , &
  11. flag_sm000007 , flag_sm007028 , flag_sm028100 , flag_sm100255
  12. INTEGER :: flag_soilt000 , flag_soilt005 , flag_soilt020 , flag_soilt040 , flag_soilt160 , flag_soilt300 , &
  13. flag_soilm000 , flag_soilm005 , flag_soilm020 , flag_soilm040 , flag_soilm160 , flag_soilm300 , &
  14. flag_soilw000 , flag_soilw005 , flag_soilw020 , flag_soilw040 , flag_soilw160 , flag_soilw300
  15. INTEGER :: flag_sst , flag_toposoil
  16. INTEGER :: flag_icedepth , flag_icefrac
  17. INTEGER :: flag_ptheta
  18. INTEGER :: flag_excluded_middle
  19. INTEGER :: num_soil_levels_input
  20. INTEGER :: num_st_levels_input , num_sm_levels_input , num_sw_levels_input
  21. INTEGER :: num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc
  22. INTEGER , DIMENSION(100) :: st_levels_input , sm_levels_input , sw_levels_input
  23. REAL , ALLOCATABLE , DIMENSION(:,:,:) :: st_input , sm_input , sw_input
  24. CHARACTER (LEN=80) , PRIVATE :: flag_name
  25. LOGICAL :: already_been_here
  26. CONTAINS
  27. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  28. SUBROUTINE init_module_optional_input ( grid , config_flags )
  29. USE module_domain , ONLY : domain
  30. USE module_configure , ONLY : grid_config_rec_type
  31. IMPLICIT NONE
  32. TYPE ( domain ) :: grid
  33. TYPE (grid_config_rec_type) :: config_flags
  34. INTEGER :: ids, ide, jds, jde, kds, kde, &
  35. ims, ime, jms, jme, kms, kme, &
  36. its, ite, jts, jte, kts, kte
  37. ! Get the various indices, assume XYZ & XZY ordering.
  38. #if (NMM_CORE==1)
  39. ids = grid%sd31 ; ide = grid%ed31 ;
  40. jds = grid%sd32 ; jde = grid%ed32 ;
  41. kds = grid%sd33 ; kde = grid%ed33 ;
  42. ims = grid%sm31 ; ime = grid%em31 ;
  43. jms = grid%sm32 ; jme = grid%em32 ;
  44. kms = grid%sm33 ; kme = grid%em33 ;
  45. its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch
  46. jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch
  47. kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch
  48. #endif
  49. #if (EM_CORE==1)
  50. ids = grid%sd31 ; ide = grid%ed31 ;
  51. kds = grid%sd32 ; kde = grid%ed32 ;
  52. jds = grid%sd33 ; jde = grid%ed33 ;
  53. ims = grid%sm31 ; ime = grid%em31 ;
  54. kms = grid%sm32 ; kme = grid%em32 ;
  55. jms = grid%sm33 ; jme = grid%em33 ;
  56. its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch
  57. kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch
  58. jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch
  59. #endif
  60. IF ( .NOT. already_been_here ) THEN
  61. num_st_levels_alloc = config_flags%num_soil_layers * 3 ! used to be 2
  62. num_sm_levels_alloc = config_flags%num_soil_layers * 3
  63. num_sw_levels_alloc = config_flags%num_soil_layers * 3
  64. IF ( ALLOCATED ( st_input ) ) DEALLOCATE ( st_input )
  65. IF ( ALLOCATED ( sm_input ) ) DEALLOCATE ( sm_input )
  66. IF ( ALLOCATED ( sw_input ) ) DEALLOCATE ( sw_input )
  67. ALLOCATE ( st_input(ims:ime,num_st_levels_alloc,jms:jme) )
  68. ALLOCATE ( sm_input(ims:ime,num_sm_levels_alloc,jms:jme) )
  69. ALLOCATE ( sw_input(ims:ime,num_sw_levels_alloc,jms:jme) )
  70. END IF
  71. already_been_here = .TRUE.
  72. END SUBROUTINE init_module_optional_input
  73. #if (DA_CORE != 1)
  74. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  75. SUBROUTINE optional_input ( grid , fid, config_flags )
  76. USE module_io_domain
  77. USE module_configure , ONLY : grid_config_rec_type
  78. USE module_domain , ONLY : domain
  79. IMPLICIT NONE
  80. TYPE ( domain ) :: grid
  81. TYPE (grid_config_rec_type) :: config_flags
  82. INTEGER , INTENT(IN) :: fid
  83. INTEGER :: ids, ide, jds, jde, kds, kde, &
  84. ims, ime, jms, jme, kms, kme, &
  85. its, ite, jts, jte, kts, kte
  86. INTEGER :: itmp , icnt , ierr, num_layers
  87. CHARACTER (LEN=132) :: message
  88. ! Get the various indices, assume XYZ & XZY ordering.
  89. #if (NMM_CORE==1)
  90. ids = grid%sd31 ; ide = grid%ed31 ;
  91. jds = grid%sd32 ; jde = grid%ed32 ;
  92. kds = grid%sd33 ; kde = grid%ed33 ;
  93. ims = grid%sm31 ; ime = grid%em31 ;
  94. jms = grid%sm32 ; jme = grid%em32 ;
  95. kms = grid%sm33 ; kme = grid%em33 ;
  96. its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch
  97. jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch
  98. kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch
  99. #endif
  100. #if (EM_CORE==1)
  101. ids = grid%sd31 ; ide = grid%ed31 ;
  102. kds = grid%sd32 ; kde = grid%ed32 ;
  103. jds = grid%sd33 ; jde = grid%ed33 ;
  104. ims = grid%sm31 ; ime = grid%em31 ;
  105. kms = grid%sm32 ; kme = grid%em32 ;
  106. jms = grid%sm33 ; jme = grid%em33 ;
  107. its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch
  108. kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch
  109. jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch
  110. #endif
  111. CALL optional_tsk ( grid , fid , &
  112. ids, ide, jds, jde, kds, kde, &
  113. ims, ime, jms, jme, kms, kme, &
  114. its, ite, jts, jte, kts, kte )
  115. CALL optional_tavgsfc ( grid , fid , &
  116. ids, ide, jds, jde, kds, kde, &
  117. ims, ime, jms, jme, kms, kme, &
  118. its, ite, jts, jte, kts, kte )
  119. CALL optional_moist ( grid , fid , &
  120. ids, ide, jds, jde, kds, kde, &
  121. ims, ime, jms, jme, kms, kme, &
  122. its, ite, jts, jte, kts, kte )
  123. CALL optional_metgrid ( grid , fid , &
  124. ids, ide, jds, jde, kds, kde, &
  125. ims, ime, jms, jme, kms, kme, &
  126. its, ite, jts, jte, kts, kte )
  127. CALL optional_sst ( grid , fid , &
  128. ids, ide, jds, jde, kds, kde, &
  129. ims, ime, jms, jme, kms, kme, &
  130. its, ite, jts, jte, kts, kte )
  131. CALL optional_snowh ( grid , fid , &
  132. ids, ide, jds, jde, kds, kde, &
  133. ims, ime, jms, jme, kms, kme, &
  134. its, ite, jts, jte, kts, kte )
  135. CALL optional_sfc ( grid , fid , &
  136. ids, ide, jds, jde, kds, kde, &
  137. ims, ime, jms, jme, kms, kme, &
  138. its, ite, jts, jte, kts, kte )
  139. CALL optional_ice ( grid , fid , &
  140. ids, ide, jds, jde, kds, kde, &
  141. ims, ime, jms, jme, kms, kme, &
  142. its, ite, jts, jte, kts, kte )
  143. CALL optional_ptheta ( grid , fid , &
  144. ids, ide, jds, jde, kds, kde, &
  145. ims, ime, jms, jme, kms, kme, &
  146. its, ite, jts, jte, kts, kte )
  147. CALL optional_excl_middle( grid , fid , &
  148. ids, ide, jds, jde, kds, kde, &
  149. ims, ime, jms, jme, kms, kme, &
  150. its, ite, jts, jte, kts, kte )
  151. flag_soil_levels = 0
  152. flag_soil_layers = 0
  153. ! How many soil levels have we found? Well, right now, none.
  154. num_st_levels_input = 0
  155. num_sm_levels_input = 0
  156. num_sw_levels_input = 0
  157. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_SOIL_LEVELS', itmp, 1, icnt, ierr )
  158. IF ( ierr .EQ. 0 ) THEN
  159. flag_soil_levels = itmp
  160. write (message,'(A50,I3)') 'flag_soil_levels read from met_em file is',flag_soil_levels
  161. CALL wrf_debug(0,message)
  162. END IF
  163. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_SOIL_LAYERS', itmp, 1, icnt, ierr )
  164. IF ( ierr .EQ. 0 ) THEN
  165. flag_soil_layers = itmp
  166. write (message,'(A50,I3)') 'flag_soil_layers read from met_em file is',flag_soil_layers
  167. CALL wrf_debug(0,message)
  168. END IF
  169. #if (EM_CORE == 1)
  170. IF ( ( flag_soil_levels == 1 ) .OR. ( flag_soil_layers == 1 ) ) THEN
  171. num_st_levels_input = config_flags%num_metgrid_soil_levels
  172. num_sm_levels_input = config_flags%num_metgrid_soil_levels
  173. num_sw_levels_input = config_flags%num_metgrid_soil_levels
  174. num_soil_levels_input = config_flags%num_metgrid_soil_levels
  175. END IF
  176. #endif
  177. IF ( ( model_config_rec%sf_surface_physics(grid%id) .EQ. 1 ) .OR. &
  178. ( model_config_rec%sf_surface_physics(grid%id) .EQ. 2 ) .OR. &
  179. ( model_config_rec%sf_surface_physics(grid%id) .EQ. 3 ) .OR. &
  180. ( model_config_rec%sf_surface_physics(grid%id) .EQ. 4 ) .OR. &
  181. ( model_config_rec%sf_surface_physics(grid%id) .EQ. 7 ) .OR. &
  182. ( model_config_rec%sf_surface_physics(grid%id) .EQ. 8 ) .OR. & !fds
  183. ( model_config_rec%sf_surface_physics(grid%id) .EQ. 88 ) ) THEN
  184. CALL optional_lsm_levels ( grid , fid , &
  185. ids, ide, jds, jde, kds, kde, &
  186. ims, ime, jms, jme, kms, kme, &
  187. its, ite, jts, jte, kts, kte )
  188. END IF
  189. END SUBROUTINE optional_input
  190. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  191. SUBROUTINE optional_moist ( grid , fid , &
  192. ids, ide, jds, jde, kds, kde, &
  193. ims, ime, jms, jme, kms, kme, &
  194. its, ite, jts, jte, kts, kte )
  195. USE module_io_wrf
  196. USE module_domain , ONLY : domain
  197. USE module_configure , ONLY : grid_config_rec_type
  198. USE module_io_domain
  199. IMPLICIT NONE
  200. TYPE ( domain ) :: grid
  201. INTEGER , INTENT(IN) :: fid
  202. INTEGER :: ids, ide, jds, jde, kds, kde, &
  203. ims, ime, jms, jme, kms, kme, &
  204. its, ite, jts, jte, kts, kte
  205. INTEGER :: itmp , icnt , ierr
  206. flag_name = ' '
  207. flag_qv = 0
  208. flag_qc = 0
  209. flag_qr = 0
  210. flag_qi = 0
  211. flag_qs = 0
  212. flag_qg = 0
  213. flag_qh = 0
  214. flag_qni = 0
  215. flag_sh = 0
  216. flag_name(1:8) = 'QV '
  217. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  218. IF ( ierr .EQ. 0 ) THEN
  219. flag_qv = itmp
  220. END IF
  221. flag_name(1:8) = 'QC '
  222. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  223. IF ( ierr .EQ. 0 ) THEN
  224. flag_qc = itmp
  225. END IF
  226. flag_name(1:8) = 'QR '
  227. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  228. IF ( ierr .EQ. 0 ) THEN
  229. flag_qr = itmp
  230. END IF
  231. flag_name(1:8) = 'QI '
  232. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  233. IF ( ierr .EQ. 0 ) THEN
  234. flag_qi = itmp
  235. END IF
  236. flag_name(1:8) = 'QS '
  237. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  238. IF ( ierr .EQ. 0 ) THEN
  239. flag_qs = itmp
  240. END IF
  241. flag_name(1:8) = 'QG '
  242. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  243. IF ( ierr .EQ. 0 ) THEN
  244. flag_qg = itmp
  245. END IF
  246. flag_name(1:8) = 'QH '
  247. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  248. IF ( ierr .EQ. 0 ) THEN
  249. flag_qh = itmp
  250. END IF
  251. flag_name(1:8) = 'QNI '
  252. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  253. IF ( ierr .EQ. 0 ) THEN
  254. flag_qni = itmp
  255. END IF
  256. flag_name(1:8) = 'SH '
  257. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  258. IF ( ierr .EQ. 0 ) THEN
  259. flag_sh = itmp
  260. END IF
  261. END SUBROUTINE optional_moist
  262. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  263. SUBROUTINE optional_metgrid ( grid , fid , &
  264. ids, ide, jds, jde, kds, kde, &
  265. ims, ime, jms, jme, kms, kme, &
  266. its, ite, jts, jte, kts, kte )
  267. USE module_io_wrf
  268. USE module_domain , ONLY : domain
  269. USE module_configure , ONLY : grid_config_rec_type
  270. USE module_io_domain
  271. IMPLICIT NONE
  272. TYPE ( domain ) :: grid
  273. INTEGER , INTENT(IN) :: fid
  274. INTEGER :: ids, ide, jds, jde, kds, kde, &
  275. ims, ime, jms, jme, kms, kme, &
  276. its, ite, jts, jte, kts, kte
  277. INTEGER :: itmp , icnt , ierr
  278. flag_name = ' '
  279. flag_metgrid = 0
  280. flag_name(1:8) = 'METGRID '
  281. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  282. IF ( ierr .EQ. 0 ) THEN
  283. flag_metgrid = itmp
  284. END IF
  285. flag_pinterp = 0
  286. flag_name(1:8) = 'P_INTERP'
  287. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  288. IF ( ierr .EQ. 0 ) THEN
  289. flag_pinterp = itmp
  290. END IF
  291. flag_mf_xy = 0
  292. flag_name(1:8) = 'MF_XY '
  293. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  294. IF ( ierr .EQ. 0 ) THEN
  295. flag_mf_xy = itmp
  296. END IF
  297. grid%flag_metgrid = flag_metgrid
  298. grid%flag_mf_xy = flag_mf_xy
  299. END SUBROUTINE optional_metgrid
  300. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  301. SUBROUTINE optional_sst ( grid , fid , &
  302. ids, ide, jds, jde, kds, kde, &
  303. ims, ime, jms, jme, kms, kme, &
  304. its, ite, jts, jte, kts, kte )
  305. USE module_io_wrf
  306. USE module_domain , ONLY : domain
  307. USE module_configure , ONLY : grid_config_rec_type
  308. USE module_io_domain
  309. IMPLICIT NONE
  310. TYPE ( domain ) :: grid
  311. INTEGER , INTENT(IN) :: fid
  312. INTEGER :: ids, ide, jds, jde, kds, kde, &
  313. ims, ime, jms, jme, kms, kme, &
  314. its, ite, jts, jte, kts, kte
  315. INTEGER :: itmp , icnt , ierr
  316. flag_name = ' '
  317. flag_sst = 0
  318. flag_name(1:8) = 'SST '
  319. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  320. IF ( ierr .EQ. 0 ) THEN
  321. flag_sst = itmp
  322. END IF
  323. END SUBROUTINE optional_sst
  324. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  325. SUBROUTINE optional_tsk ( grid , fid , &
  326. ids, ide, jds, jde, kds, kde, &
  327. ims, ime, jms, jme, kms, kme, &
  328. its, ite, jts, jte, kts, kte )
  329. USE module_io_wrf
  330. USE module_domain , ONLY : domain
  331. USE module_configure , ONLY : grid_config_rec_type
  332. USE module_io_domain
  333. IMPLICIT NONE
  334. TYPE ( domain ) :: grid
  335. INTEGER , INTENT(IN) :: fid
  336. INTEGER :: ids, ide, jds, jde, kds, kde, &
  337. ims, ime, jms, jme, kms, kme, &
  338. its, ite, jts, jte, kts, kte
  339. INTEGER :: itmp , icnt , ierr
  340. flag_name = ' '
  341. flag_tsk = 0
  342. flag_name(1:8) = 'TSK '
  343. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  344. IF ( ierr .EQ. 0 ) THEN
  345. flag_tsk = itmp
  346. END IF
  347. END SUBROUTINE optional_tsk
  348. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  349. SUBROUTINE optional_tavgsfc ( grid , fid , &
  350. ids, ide, jds, jde, kds, kde, &
  351. ims, ime, jms, jme, kms, kme, &
  352. its, ite, jts, jte, kts, kte )
  353. USE module_io_wrf
  354. USE module_domain , ONLY : domain
  355. USE module_configure , ONLY : grid_config_rec_type
  356. USE module_io_domain
  357. IMPLICIT NONE
  358. TYPE ( domain ) :: grid
  359. INTEGER , INTENT(IN) :: fid
  360. INTEGER :: ids, ide, jds, jde, kds, kde, &
  361. ims, ime, jms, jme, kms, kme, &
  362. its, ite, jts, jte, kts, kte
  363. INTEGER :: itmp , icnt , ierr
  364. flag_name = ' '
  365. flag_tavgsfc = 0
  366. flag_name(1:8) = 'TAVGSFC '
  367. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  368. IF ( ierr .EQ. 0 ) THEN
  369. flag_tavgsfc = itmp
  370. END IF
  371. END SUBROUTINE optional_tavgsfc
  372. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  373. SUBROUTINE optional_snowh ( grid , fid , &
  374. ids, ide, jds, jde, kds, kde, &
  375. ims, ime, jms, jme, kms, kme, &
  376. its, ite, jts, jte, kts, kte )
  377. USE module_io_wrf
  378. USE module_domain , ONLY : domain
  379. USE module_configure , ONLY : grid_config_rec_type
  380. USE module_io_domain
  381. IMPLICIT NONE
  382. TYPE ( domain ) :: grid
  383. INTEGER , INTENT(IN) :: fid
  384. INTEGER :: ids, ide, jds, jde, kds, kde, &
  385. ims, ime, jms, jme, kms, kme, &
  386. its, ite, jts, jte, kts, kte
  387. INTEGER :: itmp , icnt , ierr
  388. flag_name = ' '
  389. flag_snowh = 0
  390. flag_name(1:8) = 'SNOWH '
  391. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  392. IF ( ierr .EQ. 0 ) THEN
  393. flag_snowh = itmp
  394. END IF
  395. flag_snow = 0
  396. flag_name(1:8) = 'SNOW '
  397. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  398. IF ( ierr .EQ. 0 ) THEN
  399. flag_snow = itmp
  400. END IF
  401. grid%flag_snow = flag_snow
  402. END SUBROUTINE optional_snowh
  403. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  404. SUBROUTINE optional_sfc ( grid , fid , &
  405. ids, ide, jds, jde, kds, kde, &
  406. ims, ime, jms, jme, kms, kme, &
  407. its, ite, jts, jte, kts, kte )
  408. USE module_io_wrf
  409. USE module_domain , ONLY : domain
  410. USE module_configure , ONLY : grid_config_rec_type
  411. USE module_io_domain
  412. IMPLICIT NONE
  413. TYPE ( domain ) :: grid
  414. INTEGER , INTENT(IN) :: fid
  415. INTEGER :: ids, ide, jds, jde, kds, kde, &
  416. ims, ime, jms, jme, kms, kme, &
  417. its, ite, jts, jte, kts, kte
  418. INTEGER :: itmp , icnt , ierr
  419. flag_name = ' '
  420. flag_psfc = 0
  421. flag_soilhgt = 0
  422. flag_toposoil = 0
  423. flag_slp = 0
  424. flag_name(1:8) = 'TOPOSOIL'
  425. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  426. IF ( ierr .EQ. 0 ) THEN
  427. flag_toposoil = itmp
  428. END IF
  429. flag_name(1:8) = 'PSFC '
  430. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  431. IF ( ierr .EQ. 0 ) THEN
  432. flag_psfc = itmp
  433. END IF
  434. flag_name(1:8) = 'SOILHGT '
  435. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  436. IF ( ierr .EQ. 0 ) THEN
  437. flag_soilhgt = itmp
  438. END IF
  439. flag_name(1:8) = 'SLP '
  440. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  441. IF ( ierr .EQ. 0 ) THEN
  442. flag_slp = itmp
  443. END IF
  444. grid%flag_soilhgt = flag_soilhgt
  445. grid%flag_slp = flag_slp
  446. grid%flag_psfc = flag_psfc
  447. END SUBROUTINE optional_sfc
  448. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  449. SUBROUTINE optional_ice ( grid , fid , &
  450. ids, ide, jds, jde, kds, kde, &
  451. ims, ime, jms, jme, kms, kme, &
  452. its, ite, jts, jte, kts, kte )
  453. USE module_io_wrf
  454. USE module_domain , ONLY : domain
  455. USE module_configure , ONLY : grid_config_rec_type
  456. USE module_io_domain
  457. IMPLICIT NONE
  458. TYPE ( domain ) :: grid
  459. INTEGER , INTENT(IN) :: fid
  460. INTEGER :: ids, ide, jds, jde, kds, kde, &
  461. ims, ime, jms, jme, kms, kme, &
  462. its, ite, jts, jte, kts, kte
  463. INTEGER :: itmp , icnt , ierr
  464. flag_name = ' '
  465. flag_icedepth = 0
  466. flag_icefrac = 0
  467. flag_name(1:8) = 'ICEDEPTH'
  468. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  469. IF ( ierr .EQ. 0 ) THEN
  470. flag_icedepth = itmp
  471. END IF
  472. flag_name(1:8) = 'ICEFRAC '
  473. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  474. IF ( ierr .EQ. 0 ) THEN
  475. flag_icefrac = itmp
  476. END IF
  477. END SUBROUTINE optional_ice
  478. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  479. SUBROUTINE optional_ptheta ( grid , fid , &
  480. ids, ide, jds, jde, kds, kde, &
  481. ims, ime, jms, jme, kms, kme, &
  482. its, ite, jts, jte, kts, kte )
  483. USE module_io_wrf
  484. USE module_domain , ONLY : domain
  485. USE module_configure , ONLY : grid_config_rec_type
  486. USE module_io_domain
  487. IMPLICIT NONE
  488. TYPE ( domain ) :: grid
  489. INTEGER , INTENT(IN) :: fid
  490. INTEGER :: ids, ide, jds, jde, kds, kde, &
  491. ims, ime, jms, jme, kms, kme, &
  492. its, ite, jts, jte, kts, kte
  493. INTEGER :: itmp , icnt , ierr
  494. flag_name = ' '
  495. flag_ptheta = 0
  496. flag_name(1:8) = 'PTHETA '
  497. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  498. IF ( ierr .EQ. 0 ) THEN
  499. flag_ptheta = itmp
  500. END IF
  501. END SUBROUTINE optional_ptheta
  502. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  503. SUBROUTINE optional_excl_middle ( grid , fid , &
  504. ids, ide, jds, jde, kds, kde, &
  505. ims, ime, jms, jme, kms, kme, &
  506. its, ite, jts, jte, kts, kte )
  507. USE module_io_wrf
  508. USE module_domain , ONLY : domain
  509. USE module_configure , ONLY : grid_config_rec_type
  510. USE module_io_domain
  511. IMPLICIT NONE
  512. TYPE ( domain ) :: grid
  513. INTEGER , INTENT(IN) :: fid
  514. INTEGER :: ids, ide, jds, jde, kds, kde, &
  515. ims, ime, jms, jme, kms, kme, &
  516. its, ite, jts, jte, kts, kte
  517. INTEGER :: itmp , icnt , ierr
  518. flag_name = ' '
  519. flag_excluded_middle = 0
  520. flag_name(1:16) = 'EXCLUDED_MIDDLE '
  521. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  522. IF ( ierr .EQ. 0 ) THEN
  523. flag_excluded_middle = itmp
  524. END IF
  525. END SUBROUTINE optional_excl_middle
  526. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  527. SUBROUTINE optional_lsm_levels ( grid , fid , &
  528. ids, ide, jds, jde, kds, kde, &
  529. ims, ime, jms, jme, kms, kme, &
  530. its, ite, jts, jte, kts, kte )
  531. USE module_io_wrf
  532. USE module_domain , ONLY : domain
  533. !USE module_configure , ONLY : grid_config_rec_type
  534. USE module_io_domain
  535. IMPLICIT NONE
  536. TYPE ( domain ) :: grid
  537. INTEGER , INTENT(IN) :: fid
  538. INTEGER :: ids, ide, jds, jde, kds, kde, &
  539. ims, ime, jms, jme, kms, kme, &
  540. its, ite, jts, jte, kts, kte
  541. INTEGER :: itmp , icnt , ierr , i , j , k
  542. INTEGER :: level_above
  543. CHARACTER (LEN=132) :: message
  544. ! Initialize the soil temp and moisture flags to "field not found".
  545. flag_name = ' '
  546. flag_st000010 = 0
  547. flag_st010040 = 0
  548. flag_st040100 = 0
  549. flag_st100200 = 0
  550. flag_st010200 = 0
  551. flag_sm000010 = 0
  552. flag_sm010040 = 0
  553. flag_sm040100 = 0
  554. flag_sm100200 = 0
  555. flag_sm010200 = 0
  556. flag_sw000010 = 0
  557. flag_sw010040 = 0
  558. flag_sw040100 = 0
  559. flag_sw100200 = 0
  560. flag_sw010200 = 0
  561. flag_st000007 = 0
  562. flag_st007028 = 0
  563. flag_st028100 = 0
  564. flag_st100255 = 0
  565. flag_sm000007 = 0
  566. flag_sm007028 = 0
  567. flag_sm028100 = 0
  568. flag_sm100255 = 0
  569. flag_soilt000 = 0
  570. flag_soilt005 = 0
  571. flag_soilt020 = 0
  572. flag_soilt040 = 0
  573. flag_soilt160 = 0
  574. flag_soilt300 = 0
  575. flag_soilm000 = 0
  576. flag_soilm005 = 0
  577. flag_soilm020 = 0
  578. flag_soilm040 = 0
  579. flag_soilm160 = 0
  580. flag_soilm300 = 0
  581. flag_soilw000 = 0
  582. flag_soilw005 = 0
  583. flag_soilw020 = 0
  584. flag_soilw040 = 0
  585. flag_soilw160 = 0
  586. flag_soilw300 = 0
  587. st_levels_input = -1
  588. sm_levels_input = -1
  589. sw_levels_input = -1
  590. #if (EM_CORE==1)
  591. !-------------------------------------------------------------------------
  592. ! NOTE: We are assuming that soil_layers are the same for each grid point
  593. !-------------------------------------------------------------------------
  594. IF ( flag_soil_levels == 1 ) THEN
  595. DO k = 1, num_st_levels_input
  596. st_levels_input(k) = grid%soil_levels(its,num_st_levels_input + 1 - k,jts)
  597. sm_levels_input(k) = grid%soil_levels(its,num_st_levels_input + 1 - k,jts)
  598. sw_levels_input(k) = grid%soil_levels(its,num_st_levels_input + 1 - k,jts)
  599. END DO
  600. !----------------------------------------------------------------
  601. ! Flip the input soil temperature/moisture/water
  602. ! profiles upside down to make k=1 closest to the sfc
  603. !----------------------------------------------------------------
  604. DO j = jts , MIN(jde-1,jte)
  605. DO k = 1, num_st_levels_input
  606. DO i = its , MIN(ide-1,ite)
  607. st_input(i,k,j) = grid%soilt(i,num_st_levels_input + 1 - k,j)
  608. sm_input(i,k,j) = grid%soilm(i,num_st_levels_input + 1 - k,j)
  609. !-------------------------------------------------------------------------
  610. ! Initialize sw_input to 0. For 3D RUC soil moisture, there is no sw,
  611. ! but num_sw_levels_input is set to num_metgrid_soil_levels from the
  612. ! namelist causing sw_input to be used in init_soil_#_real subroutines
  613. !-------------------------------------------------------------------------
  614. sw_input(i,k,j) = 0.0
  615. END DO
  616. END DO
  617. END DO
  618. END IF ! flag_soil_levels == 1
  619. IF ( flag_soil_layers == 1 ) THEN
  620. level_above = 0
  621. DO k = 1, num_st_levels_input
  622. !-------------------------------------------------------------
  623. ! Calculate mid-point of each layer and set to st_levels_input
  624. ! Flip the input soil depths upside down to make k=1 closest to the sfc
  625. !-------------------------------------------------------------
  626. st_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2
  627. sm_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2
  628. sw_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2
  629. level_above = grid%soil_layers(its,num_st_levels_input + 1 - k,jts)
  630. END DO
  631. !----------------------------------------------------------------
  632. ! Flip the input soil temperature/moisture/water
  633. ! profiles upside down to make k=1 closest to the sfc
  634. !----------------------------------------------------------------
  635. DO j = jts , MIN(jde-1,jte)
  636. DO k = 1, num_st_levels_input
  637. DO i = its , MIN(ide-1,ite)
  638. st_input(i,k+1,j) = grid%st(i,num_st_levels_input + 1 - k,j)
  639. sm_input(i,k+1,j) = grid%sm(i,num_st_levels_input + 1 - k,j)
  640. sw_input(i,k+1,j) = grid%sw(i,num_st_levels_input + 1 - k,j)
  641. END DO
  642. END DO
  643. END DO
  644. END IF ! flag_soil_layers == 1
  645. #endif
  646. IF ( ( flag_soil_levels == 0 ) .AND. ( flag_soil_layers == 0 ) ) THEN ! Legacy code
  647. flag_name(1:8) = 'ST000010'
  648. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  649. IF ( ierr .EQ. 0 ) THEN
  650. flag_st000010 = itmp
  651. num_st_levels_input = num_st_levels_input + 1
  652. st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
  653. DO j = jts , MIN(jde-1,jte)
  654. DO i = its , MIN(ide-1,ite)
  655. st_input(i,num_st_levels_input + 1,j) = grid%st000010(i,j)
  656. END DO
  657. END DO
  658. END IF
  659. flag_name(1:8) = 'ST010040'
  660. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  661. IF ( ierr .EQ. 0 ) THEN
  662. flag_st010040 = itmp
  663. num_st_levels_input = num_st_levels_input + 1
  664. st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
  665. DO j = jts , MIN(jde-1,jte)
  666. DO i = its , MIN(ide-1,ite)
  667. st_input(i,num_st_levels_input + 1,j) = grid%st010040(i,j)
  668. END DO
  669. END DO
  670. END IF
  671. flag_name(1:8) = 'ST040100'
  672. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  673. IF ( ierr .EQ. 0 ) THEN
  674. flag_st040100 = itmp
  675. num_st_levels_input = num_st_levels_input + 1
  676. st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
  677. DO j = jts , MIN(jde-1,jte)
  678. DO i = its , MIN(ide-1,ite)
  679. st_input(i,num_st_levels_input + 1,j) = grid%st040100(i,j)
  680. END DO
  681. END DO
  682. END IF
  683. flag_name(1:8) = 'ST100200'
  684. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  685. IF ( ierr .EQ. 0 ) THEN
  686. flag_st100200 = itmp
  687. num_st_levels_input = num_st_levels_input + 1
  688. st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
  689. DO j = jts , MIN(jde-1,jte)
  690. DO i = its , MIN(ide-1,ite)
  691. st_input(i,num_st_levels_input + 1,j) = grid%st100200(i,j)
  692. END DO
  693. END DO
  694. END IF
  695. flag_name(1:8) = 'ST010200'
  696. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  697. IF ( ierr .EQ. 0 ) THEN
  698. flag_st010200 = itmp
  699. num_st_levels_input = num_st_levels_input + 1
  700. st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
  701. DO j = jts , MIN(jde-1,jte)
  702. DO i = its , MIN(ide-1,ite)
  703. st_input(i,num_st_levels_input + 1,j) = grid%st010200(i,j)
  704. END DO
  705. END DO
  706. END IF
  707. flag_name(1:8) = 'ST000007'
  708. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  709. IF ( ierr .EQ. 0 ) THEN
  710. flag_st000007 = itmp
  711. num_st_levels_input = num_st_levels_input + 1
  712. st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
  713. DO j = jts , MIN(jde-1,jte)
  714. DO i = its , MIN(ide-1,ite)
  715. st_input(i,num_st_levels_input + 1,j) = grid%st000007(i,j)
  716. END DO
  717. END DO
  718. END IF
  719. flag_name(1:8) = 'ST007028'
  720. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  721. IF ( ierr .EQ. 0 ) THEN
  722. flag_st007028 = itmp
  723. num_st_levels_input = num_st_levels_input + 1
  724. st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
  725. DO j = jts , MIN(jde-1,jte)
  726. DO i = its , MIN(ide-1,ite)
  727. st_input(i,num_st_levels_input + 1,j) = grid%st007028(i,j)
  728. END DO
  729. END DO
  730. END IF
  731. flag_name(1:8) = 'ST028100'
  732. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  733. IF ( ierr .EQ. 0 ) THEN
  734. flag_st028100 = itmp
  735. num_st_levels_input = num_st_levels_input + 1
  736. st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
  737. DO j = jts , MIN(jde-1,jte)
  738. DO i = its , MIN(ide-1,ite)
  739. st_input(i,num_st_levels_input + 1,j) = grid%st028100(i,j)
  740. END DO
  741. END DO
  742. END IF
  743. flag_name(1:8) = 'ST100255'
  744. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  745. IF ( ierr .EQ. 0 ) THEN
  746. flag_st100255 = itmp
  747. num_st_levels_input = num_st_levels_input + 1
  748. st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
  749. DO j = jts , MIN(jde-1,jte)
  750. DO i = its , MIN(ide-1,ite)
  751. st_input(i,num_st_levels_input + 1,j) = grid%st100255(i,j)
  752. END DO
  753. END DO
  754. END IF
  755. flag_name(1:8) = 'SOILT000'
  756. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  757. IF ( ierr .EQ. 0 ) THEN
  758. flag_soilt000 = itmp
  759. num_st_levels_input = num_st_levels_input + 1
  760. st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
  761. DO j = jts , MIN(jde-1,jte)
  762. DO i = its , MIN(ide-1,ite)
  763. st_input(i,num_st_levels_input ,j) = grid%soilt000(i,j)
  764. END DO
  765. END DO
  766. END IF
  767. flag_name(1:8) = 'SOILT005'
  768. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  769. IF ( ierr .EQ. 0 ) THEN
  770. flag_soilt005 = itmp
  771. num_st_levels_input = num_st_levels_input + 1
  772. st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
  773. DO j = jts , MIN(jde-1,jte)
  774. DO i = its , MIN(ide-1,ite)
  775. st_input(i,num_st_levels_input ,j) = grid%soilt005(i,j)
  776. END DO
  777. END DO
  778. END IF
  779. flag_name(1:8) = 'SOILT020'
  780. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  781. IF ( ierr .EQ. 0 ) THEN
  782. flag_soilt020 = itmp
  783. num_st_levels_input = num_st_levels_input + 1
  784. st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
  785. DO j = jts , MIN(jde-1,jte)
  786. DO i = its , MIN(ide-1,ite)
  787. st_input(i,num_st_levels_input ,j) = grid%soilt020(i,j)
  788. END DO
  789. END DO
  790. END IF
  791. flag_name(1:8) = 'SOILT040'
  792. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  793. IF ( ierr .EQ. 0 ) THEN
  794. flag_soilt040 = itmp
  795. num_st_levels_input = num_st_levels_input + 1
  796. st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
  797. DO j = jts , MIN(jde-1,jte)
  798. DO i = its , MIN(ide-1,ite)
  799. st_input(i,num_st_levels_input ,j) = grid%soilt040(i,j)
  800. END DO
  801. END DO
  802. END IF
  803. flag_name(1:8) = 'SOILT160'
  804. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  805. IF ( ierr .EQ. 0 ) THEN
  806. flag_soilt160 = itmp
  807. num_st_levels_input = num_st_levels_input + 1
  808. st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
  809. DO j = jts , MIN(jde-1,jte)
  810. DO i = its , MIN(ide-1,ite)
  811. st_input(i,num_st_levels_input ,j) = grid%soilt160(i,j)
  812. END DO
  813. END DO
  814. END IF
  815. flag_name(1:8) = 'SOILT300'
  816. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  817. IF ( ierr .EQ. 0 ) THEN
  818. flag_soilt300 = itmp
  819. num_st_levels_input = num_st_levels_input + 1
  820. st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
  821. DO j = jts , MIN(jde-1,jte)
  822. DO i = its , MIN(ide-1,ite)
  823. st_input(i,num_st_levels_input ,j) = grid%soilt300(i,j)
  824. END DO
  825. END DO
  826. END IF
  827. flag_name(1:8) = 'SM000010'
  828. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  829. IF ( ierr .EQ. 0 ) THEN
  830. flag_sm000010 = itmp
  831. num_sm_levels_input = num_sm_levels_input + 1
  832. sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
  833. DO j = jts , MIN(jde-1,jte)
  834. DO i = its , MIN(ide-1,ite)
  835. sm_input(i,num_sm_levels_input + 1,j) = grid%sm000010(i,j)
  836. END DO
  837. END DO
  838. END IF
  839. flag_name(1:8) = 'SM010040'
  840. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  841. IF ( ierr .EQ. 0 ) THEN
  842. flag_sm010040 = itmp
  843. num_sm_levels_input = num_sm_levels_input + 1
  844. sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
  845. DO j = jts , MIN(jde-1,jte)
  846. DO i = its , MIN(ide-1,ite)
  847. sm_input(i,num_sm_levels_input + 1,j) = grid%sm010040(i,j)
  848. END DO
  849. END DO
  850. END IF
  851. flag_name(1:8) = 'SM040100'
  852. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  853. IF ( ierr .EQ. 0 ) THEN
  854. flag_sm040100 = itmp
  855. num_sm_levels_input = num_sm_levels_input + 1
  856. sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
  857. DO j = jts , MIN(jde-1,jte)
  858. DO i = its , MIN(ide-1,ite)
  859. sm_input(i,num_sm_levels_input + 1,j) = grid%sm040100(i,j)
  860. END DO
  861. END DO
  862. END IF
  863. flag_name(1:8) = 'SM100200'
  864. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  865. IF ( ierr .EQ. 0 ) THEN
  866. flag_sm100200 = itmp
  867. num_sm_levels_input = num_sm_levels_input + 1
  868. sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
  869. DO j = jts , MIN(jde-1,jte)
  870. DO i = its , MIN(ide-1,ite)
  871. sm_input(i,num_sm_levels_input + 1,j) = grid%sm100200(i,j)
  872. END DO
  873. END DO
  874. END IF
  875. flag_name(1:8) = 'SM010200'
  876. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  877. IF ( ierr .EQ. 0 ) THEN
  878. flag_sm010200 = itmp
  879. num_sm_levels_input = num_sm_levels_input + 1
  880. sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
  881. DO j = jts , MIN(jde-1,jte)
  882. DO i = its , MIN(ide-1,ite)
  883. sm_input(i,num_sm_levels_input + 1,j) = grid%sm010200(i,j)
  884. END DO
  885. END DO
  886. END IF
  887. flag_name(1:8) = 'SM000007'
  888. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  889. IF ( ierr .EQ. 0 ) THEN
  890. flag_sm000007 = itmp
  891. num_sm_levels_input = num_sm_levels_input + 1
  892. sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
  893. DO j = jts , MIN(jde-1,jte)
  894. DO i = its , MIN(ide-1,ite)
  895. sm_input(i,num_sm_levels_input + 1,j) = grid%sm000007(i,j)
  896. END DO
  897. END DO
  898. END IF
  899. flag_name(1:8) = 'SM007028'
  900. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  901. IF ( ierr .EQ. 0 ) THEN
  902. flag_sm007028 = itmp
  903. num_sm_levels_input = num_sm_levels_input + 1
  904. sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
  905. DO j = jts , MIN(jde-1,jte)
  906. DO i = its , MIN(ide-1,ite)
  907. sm_input(i,num_sm_levels_input + 1,j) = grid%sm007028(i,j)
  908. END DO
  909. END DO
  910. END IF
  911. flag_name(1:8) = 'SM028100'
  912. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  913. IF ( ierr .EQ. 0 ) THEN
  914. flag_sm028100 = itmp
  915. num_sm_levels_input = num_sm_levels_input + 1
  916. sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
  917. DO j = jts , MIN(jde-1,jte)
  918. DO i = its , MIN(ide-1,ite)
  919. sm_input(i,num_sm_levels_input + 1,j) = grid%sm028100(i,j)
  920. END DO
  921. END DO
  922. END IF
  923. flag_name(1:8) = 'SM100255'
  924. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  925. IF ( ierr .EQ. 0 ) THEN
  926. flag_sm100255 = itmp
  927. num_sm_levels_input = num_sm_levels_input + 1
  928. sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
  929. DO j = jts , MIN(jde-1,jte)
  930. DO i = its , MIN(ide-1,ite)
  931. sm_input(i,num_sm_levels_input + 1,j) = grid%sm100255(i,j)
  932. END DO
  933. END DO
  934. END IF
  935. flag_name(1:8) = 'SOILM000'
  936. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  937. IF ( ierr .EQ. 0 ) THEN
  938. flag_soilm000 = itmp
  939. num_sm_levels_input = num_sm_levels_input + 1
  940. sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
  941. DO j = jts , MIN(jde-1,jte)
  942. DO i = its , MIN(ide-1,ite)
  943. sm_input(i,num_sm_levels_input ,j) = grid%soilm000(i,j)
  944. END DO
  945. END DO
  946. END IF
  947. flag_name(1:8) = 'SOILM005'
  948. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  949. IF ( ierr .EQ. 0 ) THEN
  950. flag_soilm005 = itmp
  951. num_sm_levels_input = num_sm_levels_input + 1
  952. sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
  953. DO j = jts , MIN(jde-1,jte)
  954. DO i = its , MIN(ide-1,ite)
  955. sm_input(i,num_sm_levels_input ,j) = grid%soilm005(i,j)
  956. END DO
  957. END DO
  958. END IF
  959. flag_name(1:8) = 'SOILM020'
  960. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  961. IF ( ierr .EQ. 0 ) THEN
  962. flag_soilm020 = itmp
  963. num_sm_levels_input = num_sm_levels_input + 1
  964. sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
  965. DO j = jts , MIN(jde-1,jte)
  966. DO i = its , MIN(ide-1,ite)
  967. sm_input(i,num_sm_levels_input ,j) = grid%soilm020(i,j)
  968. END DO
  969. END DO
  970. END IF
  971. flag_name(1:8) = 'SOILM040'
  972. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  973. IF ( ierr .EQ. 0 ) THEN
  974. flag_soilm040 = itmp
  975. num_sm_levels_input = num_sm_levels_input + 1
  976. sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
  977. DO j = jts , MIN(jde-1,jte)
  978. DO i = its , MIN(ide-1,ite)
  979. sm_input(i,num_sm_levels_input ,j) = grid%soilm040(i,j)
  980. END DO
  981. END DO
  982. END IF
  983. flag_name(1:8) = 'SOILM160'
  984. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  985. IF ( ierr .EQ. 0 ) THEN
  986. flag_soilm160 = itmp
  987. num_sm_levels_input = num_sm_levels_input + 1
  988. sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
  989. DO j = jts , MIN(jde-1,jte)
  990. DO i = its , MIN(ide-1,ite)
  991. sm_input(i,num_sm_levels_input ,j) = grid%soilm160(i,j)
  992. END DO
  993. END DO
  994. END IF
  995. flag_name(1:8) = 'SOILM300'
  996. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  997. IF ( ierr .EQ. 0 ) THEN
  998. flag_soilm300 = itmp
  999. num_sm_levels_input = num_sm_levels_input + 1
  1000. sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
  1001. DO j = jts , MIN(jde-1,jte)
  1002. DO i = its , MIN(ide-1,ite)
  1003. sm_input(i,num_sm_levels_input ,j) = grid%soilm300(i,j)
  1004. END DO
  1005. END DO
  1006. END IF
  1007. flag_name(1:8) = 'SW000010'
  1008. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  1009. IF ( ierr .EQ. 0 ) THEN
  1010. flag_sw000010 = itmp
  1011. num_sw_levels_input = num_sw_levels_input + 1
  1012. sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
  1013. DO j = jts , MIN(jde-1,jte)
  1014. DO i = its , MIN(ide-1,ite)
  1015. sw_input(i,num_sw_levels_input + 1,j) = grid%sw000010(i,j)
  1016. END DO
  1017. END DO
  1018. END IF
  1019. flag_name(1:8) = 'SW010040'
  1020. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  1021. IF ( ierr .EQ. 0 ) THEN
  1022. flag_sw010040 = itmp
  1023. num_sw_levels_input = num_sw_levels_input + 1
  1024. sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
  1025. DO j = jts , MIN(jde-1,jte)
  1026. DO i = its , MIN(ide-1,ite)
  1027. sw_input(i,num_sw_levels_input + 1,j) = grid%sw010040(i,j)
  1028. END DO
  1029. END DO
  1030. END IF
  1031. flag_name(1:8) = 'SW040100'
  1032. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  1033. IF ( ierr .EQ. 0 ) THEN
  1034. flag_sw040100 = itmp
  1035. num_sw_levels_input = num_sw_levels_input + 1
  1036. sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
  1037. DO j = jts , MIN(jde-1,jte)
  1038. DO i = its , MIN(ide-1,ite)
  1039. sw_input(i,num_sw_levels_input + 1,j) = grid%sw040100(i,j)
  1040. END DO
  1041. END DO
  1042. END IF
  1043. flag_name(1:8) = 'SW100200'
  1044. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  1045. IF ( ierr .EQ. 0 ) THEN
  1046. flag_sw100200 = itmp
  1047. num_sw_levels_input = num_sw_levels_input + 1
  1048. sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
  1049. DO j = jts , MIN(jde-1,jte)
  1050. DO i = its , MIN(ide-1,ite)
  1051. sw_input(i,num_sw_levels_input + 1,j) = grid%sw100200(i,j)
  1052. END DO
  1053. END DO
  1054. END IF
  1055. flag_name(1:8) = 'SW010200'
  1056. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  1057. IF ( ierr .EQ. 0 ) THEN
  1058. flag_sw010200 = itmp
  1059. num_sw_levels_input = num_sw_levels_input + 1
  1060. sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
  1061. DO j = jts , MIN(jde-1,jte)
  1062. DO i = its , MIN(ide-1,ite)
  1063. sw_input(i,num_sw_levels_input + 1,j) = grid%sw010200(i,j)
  1064. END DO
  1065. END DO
  1066. END IF
  1067. flag_name(1:8) = 'SOILW000'
  1068. CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
  1069. IF ( ierr .EQ. 0 ) THEN
  1070. flag_soilw000 = itmp
  1071. num_sw_levels_input = num_sw_levels_input + 1
  1072. sw_levels_input(num_sw_

Large files files are truncated, but you can click here to view the full file