PageRenderTime 58ms CodeModel.GetById 22ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/external/io_esmf/io_esmf.F90

http://github.com/jbeezley/wrf-fire
FORTRAN Modern | 1851 lines | 1493 code | 143 blank | 215 comment | 14 complexity | f78ba515f4735502699a0e048e66685d 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_ext_esmf
  2. ! 5.2.0r USE ESMF_Mod
  3. USE ESMF
  4. USE module_esmf_extensions
  5. IMPLICIT NONE
  6. TYPE grid_ptr
  7. TYPE(ESMF_Grid), POINTER :: ptr
  8. ! use these for error-checking for now...
  9. INTEGER :: ide_save
  10. INTEGER :: jde_save
  11. INTEGER :: kde_save
  12. LOGICAL :: in_use
  13. END TYPE grid_ptr
  14. !TODO: encapsulate this state into a class...
  15. INTEGER, PARAMETER :: int_num_handles = 99
  16. LOGICAL, DIMENSION(int_num_handles) :: okay_to_write, okay_to_read, &
  17. opened_for_write, opened_for_read, &
  18. int_handle_in_use
  19. TYPE(grid_ptr) :: grid(int_num_handles)
  20. ! convenience...
  21. CHARACTER (256) :: msg
  22. #include "wrf_io_flags.h"
  23. #include "wrf_status_codes.h"
  24. CONTAINS
  25. LOGICAL FUNCTION int_valid_handle( handle )
  26. IMPLICIT NONE
  27. INTEGER, INTENT(IN) :: handle
  28. int_valid_handle = ( handle .ge. 8 .and. handle .le. int_num_handles )
  29. END FUNCTION int_valid_handle
  30. SUBROUTINE int_get_fresh_handle( retval )
  31. INTEGER i, retval
  32. retval = -1
  33. ! dont use first 8 handles
  34. DO i = 8, int_num_handles
  35. IF ( .NOT. int_handle_in_use(i) ) THEN
  36. retval = i
  37. GOTO 33
  38. ENDIF
  39. ENDDO
  40. 33 CONTINUE
  41. IF ( retval < 0 ) THEN
  42. CALL wrf_error_fatal( "io_esmf.F90: int_get_fresh_handle() out of handles")
  43. ENDIF
  44. int_handle_in_use(retval) = .TRUE.
  45. END SUBROUTINE int_get_fresh_handle
  46. ! parse comma separated list of VARIABLE=VALUE strings and return the
  47. ! value for the matching variable if such exists, otherwise return
  48. ! the empty string
  49. SUBROUTINE get_value ( varname , str , retval )
  50. IMPLICIT NONE
  51. CHARACTER*(*) :: varname
  52. CHARACTER*(*) :: str
  53. CHARACTER*(*) :: retval
  54. CHARACTER (128) varstr, tstr
  55. INTEGER i,j,n,varstrn
  56. LOGICAL nobreak, nobreakouter
  57. varstr = TRIM(varname)//"="
  58. varstrn = len(TRIM(varstr))
  59. n = len(TRIM(str))
  60. retval = ""
  61. i = 1
  62. nobreakouter = .TRUE.
  63. DO WHILE ( nobreakouter )
  64. j = 1
  65. nobreak = .TRUE.
  66. tstr = ""
  67. DO WHILE ( nobreak )
  68. nobreak = .FALSE.
  69. IF ( i .LE. n ) THEN
  70. IF (str(i:i) .NE. ',' ) THEN
  71. tstr(j:j) = str(i:i)
  72. nobreak = .TRUE.
  73. ENDIF
  74. ENDIF
  75. j = j + 1
  76. i = i + 1
  77. ENDDO
  78. IF ( i .GT. n ) nobreakouter = .FALSE.
  79. IF ( varstr(1:varstrn) .EQ. tstr(1:varstrn) ) THEN
  80. retval(1:) = TRIM(tstr(varstrn+1:))
  81. nobreakouter = .FALSE.
  82. ENDIF
  83. ENDDO
  84. RETURN
  85. END SUBROUTINE get_value
  86. !--- ioinit
  87. SUBROUTINE init_module_ext_esmf
  88. IMPLICIT NONE
  89. INTEGER :: i
  90. DO i = 1, int_num_handles
  91. WRITE( msg,* ) 'init_module_ext_esmf: calling ioesmf_nullify_grid(',i,')'
  92. CALL wrf_debug ( 5, TRIM(msg) )
  93. CALL ioesmf_nullify_grid( i )
  94. ENDDO
  95. RETURN
  96. END SUBROUTINE init_module_ext_esmf
  97. ! allgather for integers, ESMF_style (since ESMF does not do this yet)
  98. SUBROUTINE GatherIntegerScalars_ESMF( inval, pe, numprocs, outvals )
  99. INTEGER, INTENT(IN ) :: inval ! input scalar on this task
  100. INTEGER, INTENT(IN ) :: pe ! task id
  101. INTEGER, INTENT(IN ) :: numprocs ! number of tasks
  102. INTEGER, INTENT( OUT) :: outvals(0:numprocs-1) ! gathered output vector
  103. ! Local declarations
  104. TYPE(ESMF_VM) :: vm
  105. INTEGER(ESMF_KIND_I4) :: allSnd(0:numprocs-1)
  106. INTEGER(ESMF_KIND_I4) :: allRcv(0:numprocs-1)
  107. INTEGER :: rc
  108. ! get current ESMF virtual machine for communication
  109. CALL ESMF_VMGetCurrent(vm, rc=rc)
  110. IF ( rc /= ESMF_SUCCESS ) THEN
  111. WRITE( msg,* ) 'Error in ESMF_VMGetCurrent', &
  112. __FILE__ , &
  113. ', line', &
  114. __LINE__
  115. CALL wrf_error_fatal ( msg )
  116. ENDIF
  117. allSnd = 0_ESMF_KIND_I4
  118. allSnd(pe) = inval
  119. ! Hack due to lack of ESMF_VMAllGather().
  120. ! 5.2.0r CALL ESMF_VMAllReduce(vm, allSnd, allRcv, numprocs, ESMF_SUM, rc=rc )
  121. CALL ESMF_VMAllReduce(vm, allSnd, allRcv, numprocs, ESMF_REDUCE_SUM, rc=rc )
  122. IF ( rc /= ESMF_SUCCESS ) THEN
  123. WRITE( msg,* ) 'Error in ESMF_VMAllReduce', &
  124. __FILE__ , &
  125. ', line', &
  126. __LINE__
  127. CALL wrf_error_fatal ( msg )
  128. ENDIF
  129. outvals = allRcv
  130. END SUBROUTINE GatherIntegerScalars_ESMF
  131. END MODULE module_ext_esmf
  132. ! Indexes for non-staggered variables come in at one-less than
  133. ! domain dimensions, but io_esmf is currently hacked to use full
  134. ! domain spec, so adjust if not staggered.
  135. !TODO: remove this hackery once ESMF can support staggered
  136. !TODO: grids in regional models
  137. SUBROUTINE ioesmf_endfullhack( numdims, DomainEnd, PatchEnd, Stagger, &
  138. DomainEndFull, PatchEndFull )
  139. IMPLICIT NONE
  140. INTEGER, INTENT(IN ) :: numdims
  141. INTEGER, INTENT(IN ) :: DomainEnd(numdims)
  142. INTEGER, INTENT(IN ) :: PatchEnd(numdims)
  143. CHARACTER*(*), INTENT(IN ) :: Stagger
  144. INTEGER, INTENT( OUT) :: DomainEndFull(numdims)
  145. INTEGER, INTENT( OUT) :: PatchEndFull(numdims)
  146. LOGICAL, EXTERNAL :: has_char
  147. DomainEndFull(1:numdims) = DomainEnd(1:numdims)
  148. IF ( .NOT. has_char( Stagger, 'x' ) ) DomainEndFull(1) = DomainEndFull(1) + 1
  149. IF ( .NOT. has_char( Stagger, 'y' ) ) DomainEndFull(2) = DomainEndFull(2) + 1
  150. PatchEndFull(1:numdims) = PatchEnd(1:numdims)
  151. IF ( .NOT. has_char( Stagger, 'x' ) ) THEN
  152. IF ( DomainEnd(1) == PatchEnd(1) ) PatchEndFull(1) = DomainEndFull(1)
  153. ENDIF
  154. IF ( .NOT. has_char( Stagger, 'y' ) ) THEN
  155. IF ( DomainEnd(2) == PatchEnd(2) ) PatchEndFull(2) = DomainEndFull(2)
  156. ENDIF
  157. END SUBROUTINE ioesmf_endfullhack
  158. ! Create the ESMF_Grid associated with index DataHandle.
  159. !TODO: Note that periodicity is not supported by this interface. If
  160. !TODO: periodicity is needed, pass in via SysDepInfo in the call to
  161. !TODO: ext_esmf_ioinit().
  162. !TODO: Note that lat/lon coordinates are not supported by this interface
  163. !TODO: since general curvilinear coordindates (needed for map projections
  164. !TODO: used by WRF such as polar stereographic, mercator, lambert conformal)
  165. !TODO: are not supported by ESMF as of ESMF 2.1.1. Once they are supported,
  166. !TODO: add them via the "sieve" method used in ../io_mcel/.
  167. SUBROUTINE ioesmf_create_grid( DataHandle, numdims, &
  168. MemoryOrder, Stagger, &
  169. DomainStart, DomainEnd, &
  170. MemoryStart, MemoryEnd, &
  171. PatchStart, PatchEnd )
  172. USE module_ext_esmf
  173. IMPLICIT NONE
  174. INTEGER, INTENT(IN ) :: DataHandle
  175. INTEGER, INTENT(IN ) :: numdims
  176. CHARACTER*(*), INTENT(IN ) :: MemoryOrder ! not used yet
  177. CHARACTER*(*), INTENT(IN ) :: Stagger
  178. INTEGER, INTENT(IN ) :: DomainStart(numdims), DomainEnd(numdims)
  179. INTEGER, INTENT(IN ) :: MemoryStart(numdims), MemoryEnd(numdims)
  180. INTEGER, INTENT(IN ) :: PatchStart(numdims), PatchEnd(numdims)
  181. INTEGER :: DomainEndFull(numdims)
  182. INTEGER :: PatchEndFull(numdims)
  183. WRITE( msg,* ) 'DEBUG ioesmf_create_grid: begin, DataHandle = ', DataHandle
  184. CALL wrf_debug ( 5, TRIM(msg) )
  185. ! For now, blindly create a new grid if it does not already exist for
  186. ! this DataHandle
  187. !TODO: Note that this approach will result in duplicate ESMF_Grids when
  188. !TODO: io_esmf is used for input and output. The first ESMF_Grid will
  189. !TODO: be associated with the input handle and the second will be associated
  190. !TODO: with the output handle. Fix this if ESMF_Grids are expensive.
  191. IF ( .NOT. grid( DataHandle )%in_use ) THEN
  192. IF ( ASSOCIATED( grid( DataHandle )%ptr ) ) THEN
  193. CALL wrf_error_fatal ( 'ASSERTION ERROR: grid(',DataHandle,') should be NULL' )
  194. ENDIF
  195. IF ( numdims /= 2 ) THEN
  196. CALL wrf_error_fatal ( 'ERROR: only 2D arrays supported so far with io_esmf' )
  197. ELSE
  198. WRITE( msg,* ) 'DEBUG ioesmf_create_grid: creating grid(',DataHandle,')%ptr'
  199. CALL wrf_debug ( 5, TRIM(msg) )
  200. ALLOCATE( grid( DataHandle )%ptr )
  201. grid( DataHandle )%in_use = .TRUE.
  202. ! The non-staggered variables come in at one-less than
  203. ! domain dimensions, but io_esmf is currently hacked to use full
  204. ! domain spec, so adjust if not staggered.
  205. !TODO: remove this hackery once ESMF can support staggered
  206. !TODO: grids in regional models
  207. CALL ioesmf_endfullhack( numdims, DomainEnd, PatchEnd, Stagger, &
  208. DomainEndFull, PatchEndFull )
  209. !TODO: at the moment this is hard-coded for 2D arrays
  210. !TODO: use MemoryOrder to set these properly!
  211. !TODO: also, set these once only
  212. !TODO: maybe even rip this out since it depends on a hack in input_wrf.F ...
  213. grid( DataHandle )%ide_save = DomainEndFull(1)
  214. grid( DataHandle )%jde_save = DomainEndFull(2)
  215. grid( DataHandle )%kde_save = 1
  216. WRITE( msg,* ) 'DEBUG ioesmf_create_grid: DomainEndFull = ', DomainEndFull
  217. CALL wrf_debug ( 5, TRIM(msg) )
  218. WRITE( msg,* ) 'DEBUG ioesmf_create_grid: PatchEndFull = ', PatchEndFull
  219. CALL wrf_debug ( 5, TRIM(msg) )
  220. CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid: Calling ioesmf_create_grid_int()' )
  221. CALL ioesmf_create_grid_int( grid( DataHandle )%ptr, &
  222. numdims, &
  223. DomainStart, DomainEndFull, &
  224. ! DomainStart, DomainEnd, &
  225. MemoryStart, MemoryEnd, &
  226. ! PatchStart, PatchEndFull )
  227. PatchStart, PatchEnd )
  228. CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid: back from ioesmf_create_grid_int()' )
  229. WRITE( msg,* ) 'DEBUG ioesmf_create_grid: done creating grid(',DataHandle,')%ptr'
  230. CALL wrf_debug ( 5, TRIM(msg) )
  231. ENDIF
  232. ENDIF
  233. WRITE( msg,* ) 'DEBUG ioesmf_create_grid: end'
  234. CALL wrf_debug ( 5, TRIM(msg) )
  235. END SUBROUTINE ioesmf_create_grid
  236. ! Create an ESMF_Grid that matches a WRF decomposition.
  237. !TODO: Note that periodicity is not supported by this interface. If
  238. !TODO: periodicity is needed, pass in via SysDepInfo in the call to
  239. !TODO: ext_esmf_ioinit().
  240. !TODO: Note that lat/lon coordinates are not supported by this interface
  241. !TODO: since general curvilinear coordindates (needed for map projections
  242. !TODO: used by WRF such as polar stereographic, mercator, lambert conformal)
  243. !TODO: are not supported by ESMF as of ESMF 2.1.1. Once they are supported,
  244. !TODO: add them via the "sieve" method used in ../io_mcel/.
  245. !TODO: Note that DomainEnd and PatchEnd must currently include "extra"
  246. !TODO: points for non-periodic staggered arrays. It may be possible to
  247. !TODO: remove this hackery once ESMF can support staggered
  248. !TODO: grids in regional models.
  249. SUBROUTINE ioesmf_create_grid_int( esmfgrid, numdims, &
  250. DomainStart, DomainEnd, &
  251. MemoryStart, MemoryEnd, &
  252. PatchStart, PatchEnd )
  253. USE module_ext_esmf
  254. IMPLICIT NONE
  255. TYPE(ESMF_Grid), INTENT(INOUT) :: esmfgrid
  256. INTEGER, INTENT(IN ) :: numdims
  257. INTEGER, INTENT(IN ) :: DomainStart(numdims), DomainEnd(numdims)
  258. INTEGER, INTENT(IN ) :: MemoryStart(numdims), MemoryEnd(numdims)
  259. INTEGER, INTENT(IN ) :: PatchStart(numdims), PatchEnd(numdims)
  260. ! Local declarations
  261. INTEGER :: numprocs ! total number of tasks
  262. INTEGER, ALLOCATABLE :: ipatchStarts(:), jpatchStarts(:)
  263. INTEGER :: numprocsX ! number of tasks in "i" dimension
  264. INTEGER :: numprocsY ! number of tasks in "j" dimension
  265. INTEGER, ALLOCATABLE :: permuteTasks(:)
  266. INTEGER :: globalXcount ! staggered domain count in "i" dimension
  267. INTEGER :: globalYcount ! staggered domain count in "j" dimension
  268. INTEGER :: myXstart ! task-local start in "i" dimension
  269. INTEGER :: myYstart ! task-local start in "j" dimension
  270. INTEGER :: myXend ! staggered task-local end in "i" dimension
  271. INTEGER :: myYend ! staggered task-local end in "j" dimension
  272. INTEGER, ALLOCATABLE :: allXStart(:)
  273. INTEGER, ALLOCATABLE :: allXCount(:)
  274. INTEGER, ALLOCATABLE :: dimXCount(:)
  275. INTEGER, ALLOCATABLE :: allYStart(:)
  276. INTEGER, ALLOCATABLE :: allYCount(:)
  277. INTEGER, ALLOCATABLE :: dimYCount(:)
  278. REAL(ESMF_KIND_R8), ALLOCATABLE :: coordX(:)
  279. REAL(ESMF_KIND_R8), ALLOCATABLE :: coordY(:)
  280. INTEGER, ALLOCATABLE :: cellCounts(:,:)
  281. INTEGER, ALLOCATABLE :: globalStarts(:,:)
  282. INTEGER :: rc, debug_level
  283. INTEGER :: myXcount ! task-local count in "i" dimension
  284. INTEGER :: myYcount ! task-local count in "j" dimension
  285. INTEGER :: globalCellCounts(2)
  286. INTEGER :: numprocsXY(2)
  287. INTEGER :: myPE, i, j, pe, is, ie, js, je, is_min, js_min, ie_max, je_max
  288. INTEGER :: ips, ipe, jps, jpe, ids, ide, jds, jde
  289. TYPE(ESMF_VM) :: vm
  290. TYPE(ESMF_DELayout) :: taskLayout
  291. REAL(ESMF_KIND_R8), DIMENSION(:), POINTER :: coordX2d, coordY2d
  292. INTEGER, DIMENSION(3) :: ubnd, lbnd
  293. CHARACTER (32) :: gridname
  294. INTEGER, SAVE :: gridID = 0
  295. CALL get_wrf_debug_level( debug_level )
  296. CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: begin...' )
  297. WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: numdims = ',numdims
  298. CALL wrf_debug ( 5 , TRIM(msg) )
  299. WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: DomainStart = ',DomainStart(1:numdims)
  300. CALL wrf_debug ( 5 , TRIM(msg) )
  301. WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: DomainEnd = ',DomainEnd(1:numdims)
  302. CALL wrf_debug ( 5 , TRIM(msg) )
  303. WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: MemoryStart = ',MemoryStart(1:numdims)
  304. CALL wrf_debug ( 5 , TRIM(msg) )
  305. WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: MemoryEnd = ',MemoryEnd(1:numdims)
  306. CALL wrf_debug ( 5 , TRIM(msg) )
  307. WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: PatchStart = ',PatchStart(1:numdims)
  308. CALL wrf_debug ( 5 , TRIM(msg) )
  309. WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: PatchEnd = ',PatchEnd(1:numdims)
  310. CALL wrf_debug ( 5 , TRIM(msg) )
  311. ! First, determine number of tasks and number of tasks in each decomposed
  312. ! dimension (ESMF 2.2.0 is restricted to simple task layouts)
  313. ! get current ESMF virtual machine and inquire...
  314. CALL ESMF_VMGetCurrent(vm, rc=rc)
  315. IF ( rc /= ESMF_SUCCESS ) THEN
  316. WRITE( msg,* ) 'Error in ESMF_VMGetCurrent', &
  317. __FILE__ , &
  318. ', line', &
  319. __LINE__
  320. CALL wrf_error_fatal ( msg )
  321. ENDIF
  322. !TODO: Note (PET==MPI process) assumption here. This is OK in ESMF
  323. !TODO: 2.2.0 but may change in a future ESMF release. If so, we will
  324. !TODO: need another way to do this. May want to grab mpiCommunicator
  325. !TODO: instead and ask it directly for number of MPI tasks. Unless this
  326. !TODO: is a serial run...
  327. CALL ESMF_VMGet(vm, petCount=numprocs, localPet=myPE, rc=rc)
  328. IF ( rc /= ESMF_SUCCESS ) THEN
  329. WRITE( msg,* ) 'Error in ESMF_VMGet', &
  330. __FILE__ , &
  331. ', line', &
  332. __LINE__
  333. CALL wrf_error_fatal ( msg )
  334. ENDIF
  335. ALLOCATE( ipatchStarts(0:numprocs-1), jpatchStarts(0:numprocs-1) )
  336. CALL GatherIntegerScalars_ESMF(PatchStart(1), myPE, numprocs, ipatchStarts)
  337. CALL GatherIntegerScalars_ESMF(PatchStart(2), myPE, numprocs, jpatchStarts)
  338. numprocsX = 0
  339. numprocsY = 0
  340. DO pe = 0, numprocs-1
  341. IF ( PatchStart(1) == ipatchStarts(pe) ) THEN
  342. numprocsY = numprocsY + 1
  343. ENDIF
  344. IF ( PatchStart(2) == jpatchStarts(pe) ) THEN
  345. numprocsX = numprocsX + 1
  346. ENDIF
  347. ENDDO
  348. DEALLOCATE( ipatchStarts, jpatchStarts )
  349. WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: numprocsX = ',numprocsX
  350. CALL wrf_debug ( 5 , TRIM(msg) )
  351. WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: numprocsY = ',numprocsY
  352. CALL wrf_debug ( 5 , TRIM(msg) )
  353. ! sanity check
  354. IF ( numprocs /= numprocsX*numprocsY ) THEN
  355. CALL wrf_error_fatal ( 'ASSERTION FAILED: numprocs /= numprocsX*numprocsY' )
  356. ENDIF
  357. ! Next, create ESMF_DELayout
  358. numprocsXY = (/ numprocsX, numprocsY /)
  359. !TODO: 1-to-1 DE to PET mapping is assumed below...
  360. ALLOCATE( permuteTasks(0:numprocs-1) )
  361. pe = 0
  362. DO j = 0, numprocsY-1
  363. DO i = 0, numprocsX-1
  364. ! NOTE: seems to work both ways...
  365. ! (/ 0 2 1 3 /)
  366. ! permuteTasks(pe) = (i*numprocsY) + j
  367. ! (/ 0 1 2 3 /)
  368. permuteTasks(pe) = pe
  369. pe = pe + 1
  370. ENDDO
  371. ENDDO
  372. WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: numprocsXY = ',numprocsXY
  373. CALL wrf_debug ( 5 , TRIM(msg) )
  374. WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int: permuteTasks = ',permuteTasks
  375. CALL wrf_debug ( 5 , TRIM(msg) )
  376. CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: calling ESMF_DELayoutCreate' )
  377. taskLayout = ESMF_DELayoutCreate( vm, numprocsXY, petList=permuteTasks, rc=rc )
  378. IF ( rc /= ESMF_SUCCESS ) THEN
  379. WRITE( msg,* ) 'Error in ESMF_DELayoutCreate', &
  380. __FILE__ , &
  381. ', line', &
  382. __LINE__
  383. CALL wrf_error_fatal ( msg )
  384. ENDIF
  385. CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: back from ESMF_DELayoutCreate' )
  386. DEALLOCATE( permuteTasks )
  387. CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: calling ESMF_DELayoutPrint 1' )
  388. IF ( 5 .LE. debug_level ) THEN
  389. CALL ESMF_DELayoutPrint( taskLayout, rc=rc )
  390. ENDIF
  391. CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: back from ESMF_DELayoutPrint 1' )
  392. ! Compute the dimensions for the ESMF grid, using WRF's non-staggered dimensions
  393. ! This is as of ESMF v3, JM 20080715
  394. ! the [ij][dp][se] bits are for convenience...
  395. ids = DomainStart(1); ide = DomainEnd(1);
  396. jds = DomainStart(2); jde = DomainEnd(2);
  397. ips = PatchStart(1); ipe = PatchEnd(1);
  398. jps = PatchStart(2); jpe = PatchEnd(2);
  399. globalXcount = ide - ids ! in other words, the number of points from ids to ide-1 inclusive
  400. globalYcount = jde - jds ! in other words, the number of points from jds to jde-1 inclusive
  401. ! task-local numbers of points in patch for staggered arrays
  402. myXstart = ips
  403. myYstart = jps
  404. myXend = MIN(ipe,ide-1)
  405. myYend = MIN(jpe,jde-1)
  406. myXcount = myXend - myXstart + 1
  407. myYcount = myYend - myYstart + 1
  408. ! gather task-local information on all tasks since
  409. ! ESMF_GridDistribute[Block] interface require global knowledge to set up
  410. ! decompositions
  411. ! Recall that coordX and coordY are coordinates of *vertices*, not cell centers.
  412. ! Thus they must be 1 bigger than the number of cells.
  413. ALLOCATE( allXStart(0:numprocs-1), allXCount(0:numprocs-1), &
  414. allYStart(0:numprocs-1), allYCount(0:numprocs-1), &
  415. dimXCount(0:numprocsX-1), dimYCount(0:numprocsY-1), &
  416. coordX(globalXcount+1), coordY(globalYcount+1) )
  417. CALL GatherIntegerScalars_ESMF(myXcount, myPE, numprocs, allXCount)
  418. CALL GatherIntegerScalars_ESMF(myXstart, myPE, numprocs, allXStart)
  419. CALL GatherIntegerScalars_ESMF(myYcount, myPE, numprocs, allYCount)
  420. CALL GatherIntegerScalars_ESMF(myYstart, myPE, numprocs, allYStart)
  421. !TODO: ESMF 2.x does not support mercator, polar-stereographic, or
  422. !TODO: lambert-conformal projections. Therefore, we're using fake
  423. !TODO: coordinates here. This means that WRF will either have to
  424. !TODO: couple to models that run on the same coorindate such that
  425. !TODO: grid points are co-located or something else will have to
  426. !TODO: perform the inter-grid interpolation computations. Replace
  427. !TODO: this once ESMF is upgraded to support the above map
  428. !TODO: projections (via general curvilinear coordinates).
  429. CALL wrf_message( 'WARNING: Using artificial coordinates for ESMF coupling.' )
  430. CALL wrf_message( 'WARNING: ESMF coupling interpolation will be incorrect' )
  431. CALL wrf_message( 'WARNING: unless grid points in the coupled components' )
  432. CALL wrf_message( 'WARNING: are co-located. This limitation will be removed' )
  433. CALL wrf_message( 'WARNING: once ESMF coupling supports generalized' )
  434. CALL wrf_message( 'WARNING: curvilinear coordintates needed to represent' )
  435. CALL wrf_message( 'WARNING: common map projections used by WRF and other' )
  436. CALL wrf_message( 'WARNING: regional models.' )
  437. ! Note that ESMF defines coordinates at *vertices*
  438. coordX(1) = 0.0
  439. DO i = 2, SIZE(coordX)
  440. coordX(i) = coordX(i-1) + 1.0
  441. ENDDO
  442. coordY(1) = 0.0
  443. DO j = 2, SIZE(coordY)
  444. coordY(j) = coordY(j-1) + 1.0
  445. ENDDO
  446. ! Create an ESMF_Grid
  447. ! For now we create only a 2D grid suitable for simple coupling of 2D
  448. ! surface fields. Later, create and subset one or more 3D grids.
  449. !TODO: Pass staggering info into this routine once ESMF can support staggered
  450. !TODO: grids. For now, it is hard-coded for WRF-ARW.
  451. gridID = gridID + 1
  452. WRITE ( gridname,'(a,i0)' ) 'WRF_grid_', gridID
  453. CALL wrf_debug ( 5 , 'DEBUG WRF: Calling ESMF_GridCreate' )
  454. WRITE( msg,* ) 'DEBUG WRF: SIZE(coordX) = ', SIZE(coordX)
  455. CALL wrf_debug ( 5 , TRIM(msg) )
  456. WRITE( msg,* ) 'DEBUG WRF: SIZE(coordY) = ', SIZE(coordY)
  457. CALL wrf_debug ( 5 , TRIM(msg) )
  458. DO i = 1, SIZE(coordX)
  459. WRITE( msg,* ) 'DEBUG WRF: coord1(',i,') = ', coordX(i)
  460. CALL wrf_debug ( 5 , TRIM(msg) )
  461. ENDDO
  462. DO j = 1, SIZE(coordY)
  463. WRITE( msg,* ) 'DEBUG WRF: coord2(',j,') = ', coordY(j)
  464. CALL wrf_debug ( 5 , TRIM(msg) )
  465. ENDDO
  466. !WRITE( msg,* ) 'DEBUG WRF: horzstagger = ', ESMF_GRID_HORZ_STAGGER_C_SW
  467. !CALL wrf_debug ( 5 , TRIM(msg) )
  468. WRITE( msg,* ) 'DEBUG WRF: name = ', TRIM(gridname)
  469. CALL wrf_debug ( 5 , TRIM(msg) )
  470. ! distribute the ESMF_Grid
  471. ! ignore repeated values
  472. is_min = MINVAL(allXStart)
  473. js_min = MINVAL(allYStart)
  474. i = 0
  475. j = 0
  476. WRITE( msg,* ) 'DEBUG: is_min = ',is_min,' allXStart = ',allXStart
  477. CALL wrf_debug ( 5 , TRIM(msg) )
  478. WRITE( msg,* ) 'DEBUG: js_min = ',js_min,' allYStart = ',allYStart
  479. CALL wrf_debug ( 5 , TRIM(msg) )
  480. WRITE( msg,* ) 'DEBUG: allXCount = ',allXCount
  481. CALL wrf_debug ( 5 , TRIM(msg) )
  482. WRITE( msg,* ) 'DEBUG: allYCount = ',allYCount
  483. CALL wrf_debug ( 5 , TRIM(msg) )
  484. DO pe = 0, numprocs-1
  485. IF (allXStart(pe) == is_min) THEN
  486. IF (j >= numprocsY) THEN
  487. WRITE( msg,* ) 'ASSERTION FAILED in ESMF_GridCreate', &
  488. __FILE__ , &
  489. ', line', &
  490. __LINE__
  491. CALL wrf_error_fatal ( msg )
  492. ENDIF
  493. WRITE( msg,* ) 'DEBUG: dimYCount(',j,') == allYCount(',pe,')'
  494. CALL wrf_debug ( 5 , TRIM(msg) )
  495. dimYCount(j) = allYCount(pe)
  496. j = j + 1
  497. ENDIF
  498. IF (allYStart(pe) == js_min) THEN
  499. IF (i >= numprocsX) THEN
  500. WRITE( msg,* ) 'ASSERTION FAILED in ESMF_GridCreate', &
  501. __FILE__ , &
  502. ', line', &
  503. __LINE__
  504. CALL wrf_error_fatal ( msg )
  505. ENDIF
  506. WRITE( msg,* ) 'DEBUG: dimXCount(',i,') == allXCount(',pe,')'
  507. CALL wrf_debug ( 5 , TRIM(msg) )
  508. dimXCount(i) = allXCount(pe)
  509. i = i + 1
  510. ENDIF
  511. ENDDO
  512. WRITE( msg,* ) 'DEBUG: i = ',i,' dimXCount = ',dimXCount
  513. CALL wrf_debug ( 5 , TRIM(msg) )
  514. WRITE( msg,* ) 'DEBUG: j = ',j,' dimYCount = ',dimYCount
  515. CALL wrf_debug ( 5 , TRIM(msg) )
  516. #if 0
  517. esmfgrid = ESMF_GridCreateHorzXY( &
  518. coord1=coordX, coord2=coordY, &
  519. horzstagger=ESMF_GRID_HORZ_STAGGER_C_SW, &
  520. !TODO: use this for 3D Grids once it is stable
  521. ! coordorder=ESMF_COORD_ORDER_XZY, &
  522. name=TRIM(gridname), rc=rc )
  523. #else
  524. ! based on example in 3.1 ref man sec 23.2.5, Creating an Irregularly
  525. ! Distributed Rectilinear Grid with a Non-Distributed Vertical Dimension
  526. !esmfgrid = ESMF_GridCreateShapeTile( &
  527. !write(0,*)'calling ESMF_GridCreateShapeTile for grid named ',trim(gridname)
  528. !write(0,*)'calling ESMF_GridCreateShapeTile dimXCount ',dimXCount
  529. !write(0,*)'calling ESMF_GridCreateShapeTile dimYCount ',dimYCount
  530. ! 5.2.0r esmfgrid = ESMF_GridCreateShapeTile( &
  531. esmfgrid = ESMF_GridCreate( &
  532. countsPerDEDim1=dimXCount , &
  533. countsPerDEDim2=dimYcount , &
  534. coordDep1=(/1/) , &
  535. coordDep2=(/2/) , &
  536. indexflag=ESMF_INDEX_GLOBAL, & ! use global indices
  537. name=TRIM(gridname), &
  538. rc = rc )
  539. CALL ESMF_GridAddCoord(esmfgrid, &
  540. staggerloc=ESMF_STAGGERLOC_CENTER, &
  541. rc=rc)
  542. CALL ESMF_GridGetCoord(esmfgrid,coordDim=1,localDE=0, &
  543. staggerloc=ESMF_STAGGERLOC_CENTER, &
  544. computationalLBound=lbnd,computationalUBound=ubnd, &
  545. farrayptr=coordX2d, &
  546. rc=rc)
  547. DO i=lbnd(1),ubnd(1)
  548. coordX2d(i) = (i-1)*1.0
  549. ENDDO
  550. CALL ESMF_GridGetCoord(esmfgrid,coordDim=2,localDE=0, &
  551. staggerloc=ESMF_STAGGERLOC_CENTER, &
  552. computationalLBound=lbnd,computationalUBound=ubnd, &
  553. farrayptr=coordY2d, &
  554. rc=rc)
  555. DO i=lbnd(1),ubnd(1)
  556. coordY2d(i) = (i-1)*1.0
  557. ENDDO
  558. #endif
  559. IF ( rc /= ESMF_SUCCESS ) THEN
  560. WRITE( msg,* ) 'Error in ESMF_GridCreate', &
  561. __FILE__ , &
  562. ', line', &
  563. __LINE__
  564. CALL wrf_error_fatal ( msg )
  565. ENDIF
  566. CALL wrf_debug ( 5 , 'DEBUG WRF: back OK from ESMF_GridCreate' )
  567. CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: calling ESMF_DELayoutPrint 2' )
  568. IF ( 5 .LE. debug_level ) THEN
  569. CALL ESMF_DELayoutPrint( taskLayout, rc=rc )
  570. ENDIF
  571. CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: back from ESMF_DELayoutPrint 2' )
  572. #if 0
  573. CALL ESMF_GridDistribute( esmfgrid, &
  574. delayout=taskLayout, &
  575. countsPerDEDim1=dimXCount, &
  576. countsPerDEDim2=dimYCount, &
  577. rc=rc )
  578. IF ( rc /= ESMF_SUCCESS ) THEN
  579. WRITE( msg,* ) 'Error in ESMF_GridDistribute ', &
  580. __FILE__ , &
  581. ', line ', &
  582. __LINE__ , &
  583. ', error code = ',rc
  584. CALL wrf_error_fatal ( msg )
  585. ENDIF
  586. #endif
  587. CALL wrf_debug ( 5 , 'DEBUG WRF: Calling ESMF_GridValidate()' )
  588. CALL ESMF_GridValidate( esmfgrid, rc=rc )
  589. IF ( rc /= ESMF_SUCCESS ) THEN
  590. WRITE( msg,* ) 'Error in ESMF_GridValidate ', &
  591. __FILE__ , &
  592. ', line ', &
  593. __LINE__ , &
  594. ', error code = ',rc
  595. CALL wrf_error_fatal ( msg )
  596. ENDIF
  597. CALL wrf_debug ( 5 , 'DEBUG WRF: back OK from ESMF_GridValidate()' )
  598. DEALLOCATE( allXStart, allXCount, allYStart, allYCount, &
  599. dimXCount, dimYCount, coordX, coordY )
  600. #if 0
  601. ! Print out the ESMF decomposition info for debug comparison with WRF
  602. ! decomposition info.
  603. ALLOCATE( cellCounts(0:numprocs-1,2), globalStarts(0:numprocs-1,2) )
  604. ! extract information about staggered grids for debugging
  605. CALL ESMF_GridGet( esmfgrid, &
  606. horzrelloc=ESMF_CELL_WFACE, &
  607. globalStartPerDEPerDim=globalStarts, &
  608. cellCountPerDEPerDim=cellCounts, &
  609. globalCellCountPerDim=globalCellCounts, &
  610. rc=rc )
  611. IF ( rc /= ESMF_SUCCESS ) THEN
  612. WRITE( msg,* ) 'Error in ESMF_GridGet', &
  613. __FILE__ , &
  614. ', line', &
  615. __LINE__
  616. CALL wrf_error_fatal ( msg )
  617. ENDIF
  618. ! note that global indices in ESMF_Grid always start at zero
  619. WRITE( msg,* ) 'DEBUG: ESMF staggered ips = ',1+globalStarts(myPE,1)
  620. CALL wrf_debug ( 5 , TRIM(msg) )
  621. WRITE( msg,* ) 'DEBUG: ESMF staggered ipe = ',1+globalStarts(myPE,1) + cellCounts(myPE,1) - 1
  622. CALL wrf_debug ( 5 , TRIM(msg) )
  623. WRITE( msg,* ) 'DEBUG: ESMF staggered i count = ', cellCounts(myPE,1)
  624. CALL wrf_debug ( 5 , TRIM(msg) )
  625. CALL ESMF_GridGet( esmfgrid, &
  626. horzrelloc=ESMF_CELL_SFACE, &
  627. globalStartPerDEPerDim=globalStarts, &
  628. cellCountPerDEPerDim=cellCounts, &
  629. globalCellCountPerDim=globalCellCounts, &
  630. rc=rc )
  631. IF ( rc /= ESMF_SUCCESS ) THEN
  632. WRITE( msg,* ) 'Error in ESMF_GridGet', &
  633. __FILE__ , &
  634. ', line', &
  635. __LINE__
  636. CALL wrf_error_fatal ( msg )
  637. ENDIF
  638. ! note that global indices in ESMF_Grid always start at zero
  639. WRITE( msg,* ) 'DEBUG: ESMF staggered jps = ',1+globalStarts(myPE,2)
  640. CALL wrf_debug ( 5 , TRIM(msg) )
  641. WRITE( msg,* ) 'DEBUG: ESMF staggered jpe = ',1+globalStarts(myPE,2) + cellCounts(myPE,2) - 1
  642. CALL wrf_debug ( 5 , TRIM(msg) )
  643. WRITE( msg,* ) 'DEBUG: ESMF staggered j count = ', cellCounts(myPE,2)
  644. CALL wrf_debug ( 5 , TRIM(msg) )
  645. DEALLOCATE( cellCounts, globalStarts )
  646. CALL wrf_debug ( 100 , 'DEBUG ioesmf_create_grid_int: print esmfgrid BEGIN...' )
  647. IF ( 100 .LE. debug_level ) THEN
  648. CALL ESMF_GridPrint( esmfgrid, rc=rc )
  649. IF ( rc /= ESMF_SUCCESS ) THEN
  650. WRITE( msg,* ) 'Error in ESMF_GridPrint', &
  651. __FILE__ , &
  652. ', line', &
  653. __LINE__
  654. CALL wrf_error_fatal ( msg )
  655. ENDIF
  656. ENDIF
  657. CALL wrf_debug ( 100 , 'DEBUG ioesmf_create_grid_int: print esmfgrid END' )
  658. #endif
  659. CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int: returning...' )
  660. END SUBROUTINE ioesmf_create_grid_int
  661. ! Destroy the ESMF_Grid associated with index DataHandle.
  662. ! grid( DataHandle )%ptr is DEALLOCATED (NULLIFIED)
  663. SUBROUTINE ioesmf_destroy_grid( DataHandle )
  664. USE module_ext_esmf
  665. IMPLICIT NONE
  666. INTEGER, INTENT(IN ) :: DataHandle
  667. ! Local declarations
  668. INTEGER :: id, rc
  669. TYPE(ESMF_DELayout) :: taskLayout
  670. LOGICAL :: noneLeft
  671. IF ( grid( DataHandle )%in_use ) THEN
  672. #if 0
  673. WRITE( msg,* ) 'DEBUG: ioesmf_destroy_grid( ',DataHandle,' ) begin...'
  674. CALL wrf_debug ( 5 , TRIM(msg) )
  675. CALL ESMF_GridGet( grid( DataHandle )%ptr, delayout=taskLayout, rc=rc )
  676. IF ( rc /= ESMF_SUCCESS ) THEN
  677. WRITE( msg,* ) 'Error in ESMF_GridGet', &
  678. __FILE__ , &
  679. ', line', &
  680. __LINE__
  681. CALL wrf_error_fatal ( msg )
  682. ENDIF
  683. ! I "know" I created this... (not really, but ESMF cannot tell me!)
  684. CALL ESMF_DELayoutDestroy( taskLayout, rc=rc )
  685. IF ( rc /= ESMF_SUCCESS ) THEN
  686. WRITE( msg,* ) 'Error in ESMF_DELayoutDestroy', &
  687. __FILE__ , &
  688. ', line', &
  689. __LINE__
  690. CALL wrf_error_fatal ( msg )
  691. ENDIF
  692. #endif
  693. CALL ESMF_GridDestroy( grid( DataHandle )%ptr, rc=rc )
  694. IF ( rc /= ESMF_SUCCESS ) THEN
  695. WRITE( msg,* ) 'Error in ESMF_GridDestroy', &
  696. __FILE__ , &
  697. ', line', &
  698. __LINE__
  699. CALL wrf_error_fatal ( msg )
  700. ENDIF
  701. DEALLOCATE( grid( DataHandle )%ptr )
  702. CALL ioesmf_nullify_grid( DataHandle )
  703. WRITE( msg,* ) 'DEBUG: ioesmf_destroy_grid( ',DataHandle,' ) end'
  704. CALL wrf_debug ( 5 , TRIM(msg) )
  705. ENDIF
  706. END SUBROUTINE ioesmf_destroy_grid
  707. ! Nullify the grid_ptr associated with index DataHandle.
  708. ! grid( DataHandle )%ptr must not be associated
  709. ! DataHandle must be in a valid range
  710. SUBROUTINE ioesmf_nullify_grid( DataHandle )
  711. USE module_ext_esmf
  712. IMPLICIT NONE
  713. INTEGER, INTENT(IN ) :: DataHandle
  714. NULLIFY( grid( DataHandle )%ptr )
  715. grid( DataHandle )%in_use = .FALSE.
  716. grid( DataHandle )%ide_save = 0
  717. grid( DataHandle )%jde_save = 0
  718. grid( DataHandle )%kde_save = 0
  719. END SUBROUTINE ioesmf_nullify_grid
  720. !TODO: use generic explicit interfaces and remove duplication
  721. !TODO: use cpp to remove duplication
  722. SUBROUTINE ioesmf_extract_data_real( data_esmf_real, Field, &
  723. ips, ipe, jps, jpe, kps, kpe, &
  724. ims, ime, jms, jme, kms, kme )
  725. USE module_ext_esmf
  726. IMPLICIT NONE
  727. INTEGER, INTENT(IN ) :: ips, ipe, jps, jpe, kps, kpe
  728. INTEGER, INTENT(IN ) :: ims, ime, jms, jme, kms, kme
  729. REAL(ESMF_KIND_R4), INTENT(IN ) :: data_esmf_real( ips:ipe, jps:jpe )
  730. REAL, INTENT( OUT) :: Field( ims:ime, jms:jme, kms:kme )
  731. Field( ips:ipe, jps:jpe, kms ) = data_esmf_real( ips:ipe, jps:jpe )
  732. END SUBROUTINE ioesmf_extract_data_real
  733. !TODO: use cpp to remove duplication
  734. SUBROUTINE ioesmf_extract_data_int( data_esmf_int, Field, &
  735. ips, ipe, jps, jpe, kps, kpe, &
  736. ims, ime, jms, jme, kms, kme )
  737. USE module_ext_esmf
  738. IMPLICIT NONE
  739. INTEGER, INTENT(IN ) :: ips, ipe, jps, jpe, kps, kpe
  740. INTEGER, INTENT(IN ) :: ims, ime, jms, jme, kms, kme
  741. INTEGER(ESMF_KIND_I4), INTENT(IN ) :: data_esmf_int( ips:ipe, jps:jpe )
  742. INTEGER, INTENT( OUT) :: Field( ims:ime, jms:jme, kms:kme )
  743. Field( ips:ipe, jps:jpe, kms ) = data_esmf_int( ips:ipe, jps:jpe )
  744. END SUBROUTINE ioesmf_extract_data_int
  745. !TODO: use cpp to remove duplication
  746. SUBROUTINE ioesmf_insert_data_real( Field, data_esmf_real, &
  747. ips, ipe, jps, jpe, kps, kpe, &
  748. ims, ime, jms, jme, kms, kme )
  749. USE module_ext_esmf
  750. IMPLICIT NONE
  751. INTEGER, INTENT(IN ) :: ips, ipe, jps, jpe, kps, kpe
  752. INTEGER, INTENT(IN ) :: ims, ime, jms, jme, kms, kme
  753. REAL, INTENT(IN ) :: Field( ims:ime, jms:jme, kms:kme )
  754. REAL(ESMF_KIND_R4), INTENT( OUT) :: data_esmf_real( ips:ipe, jps:jpe )
  755. !TODO: Remove this hack once we no longer have to store non-staggered
  756. !TODO: arrays in space dimensioned for staggered arrays.
  757. data_esmf_real = 0.0_ESMF_KIND_R4
  758. data_esmf_real( ips:ipe, jps:jpe ) = Field( ips:ipe, jps:jpe, kms )
  759. END SUBROUTINE ioesmf_insert_data_real
  760. !TODO: use cpp to remove duplication
  761. SUBROUTINE ioesmf_insert_data_int( Field, data_esmf_int, &
  762. ips, ipe, jps, jpe, kps, kpe, &
  763. ims, ime, jms, jme, kms, kme )
  764. USE module_ext_esmf
  765. IMPLICIT NONE
  766. INTEGER, INTENT(IN ) :: ips, ipe, jps, jpe, kps, kpe
  767. INTEGER, INTENT(IN ) :: ims, ime, jms, jme, kms, kme
  768. INTEGER, INTENT(IN ) :: Field( ims:ime, jms:jme, kms:kme )
  769. INTEGER(ESMF_KIND_I4), INTENT( OUT) :: data_esmf_int( ips:ipe, jps:jpe )
  770. !TODO: Remove this hack once we no longer have to store non-staggered
  771. !TODO: arrays in space dimensioned for staggered arrays.
  772. data_esmf_int = 0.0_ESMF_KIND_I4
  773. data_esmf_int( ips:ipe, jps:jpe ) = Field( ips:ipe, jps:jpe, kms )
  774. END SUBROUTINE ioesmf_insert_data_int
  775. !--------------
  776. SUBROUTINE ext_esmf_ioinit( SysDepInfo, Status )
  777. USE module_ext_esmf
  778. IMPLICIT NONE
  779. CHARACTER*(*), INTENT(IN) :: SysDepInfo
  780. INTEGER Status
  781. CALL init_module_ext_esmf
  782. Status = 0
  783. END SUBROUTINE ext_esmf_ioinit
  784. !--- open_for_read
  785. SUBROUTINE ext_esmf_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
  786. DataHandle , Status )
  787. USE module_ext_esmf
  788. IMPLICIT NONE
  789. CHARACTER*(*) :: FileName
  790. INTEGER , INTENT(IN) :: Comm_compute , Comm_io
  791. CHARACTER*(*) :: SysDepInfo
  792. INTEGER , INTENT(OUT) :: DataHandle
  793. INTEGER , INTENT(OUT) :: Status
  794. CALL wrf_debug(1,'ext_esmf_open_for_read not supported yet')
  795. Status = WRF_WARN_NOTSUPPORTED
  796. RETURN
  797. END SUBROUTINE ext_esmf_open_for_read
  798. !--- inquire_opened
  799. SUBROUTINE ext_esmf_inquire_opened ( DataHandle, FileName , FileStatus, Status )
  800. USE module_ext_esmf
  801. IMPLICIT NONE
  802. INTEGER , INTENT(IN) :: DataHandle
  803. CHARACTER*(*) :: FileName
  804. INTEGER , INTENT(OUT) :: FileStatus
  805. INTEGER , INTENT(OUT) :: Status
  806. Status = 0
  807. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: begin, DataHandle = ', DataHandle
  808. CALL wrf_debug ( 5 , TRIM(msg) )
  809. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: int_valid_handle(',DataHandle,') = ', &
  810. int_valid_handle( DataHandle )
  811. CALL wrf_debug ( 5 , TRIM(msg) )
  812. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: int_handle_in_use(',DataHandle,') = ', &
  813. int_handle_in_use( DataHandle )
  814. CALL wrf_debug ( 5 , TRIM(msg) )
  815. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: opened_for_read(',DataHandle,') = ', &
  816. opened_for_read( DataHandle )
  817. CALL wrf_debug ( 5 , TRIM(msg) )
  818. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: okay_to_read(',DataHandle,') = ', &
  819. okay_to_read( DataHandle )
  820. CALL wrf_debug ( 5 , TRIM(msg) )
  821. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: opened_for_write(',DataHandle,') = ', &
  822. opened_for_write( DataHandle )
  823. CALL wrf_debug ( 5 , TRIM(msg) )
  824. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: okay_to_write(',DataHandle,') = ', &
  825. okay_to_write( DataHandle )
  826. CALL wrf_debug ( 5 , TRIM(msg) )
  827. !TODO: need to cache file name and match with FileName argument and return
  828. !TODO: FileStatus = WRF_FILE_NOT_OPENED if they do not match
  829. FileStatus = WRF_FILE_NOT_OPENED
  830. IF ( int_valid_handle( DataHandle ) ) THEN
  831. IF ( int_handle_in_use( DataHandle ) ) THEN
  832. IF ( opened_for_read ( DataHandle ) ) THEN
  833. IF ( okay_to_read( DataHandle ) ) THEN
  834. FileStatus = WRF_FILE_OPENED_FOR_READ
  835. ELSE
  836. FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
  837. ENDIF
  838. ELSE IF ( opened_for_write( DataHandle ) ) THEN
  839. IF ( okay_to_write( DataHandle ) ) THEN
  840. FileStatus = WRF_FILE_OPENED_FOR_WRITE
  841. ELSE
  842. FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
  843. ENDIF
  844. ELSE
  845. FileStatus = WRF_FILE_NOT_OPENED
  846. ENDIF
  847. ENDIF
  848. WRITE( msg,* ) 'ERROR ext_esmf_inquire_opened: file handle ',DataHandle,' is invalid'
  849. CALL wrf_error_fatal ( TRIM(msg) )
  850. ENDIF
  851. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened: end, FileStatus = ', FileStatus
  852. CALL wrf_debug ( 5 , TRIM(msg) )
  853. Status = 0
  854. RETURN
  855. END SUBROUTINE ext_esmf_inquire_opened
  856. !--- inquire_filename
  857. SUBROUTINE ext_esmf_inquire_filename ( DataHandle, FileName , FileStatus, Status )
  858. USE module_ext_esmf
  859. IMPLICIT NONE
  860. INTEGER , INTENT(IN) :: DataHandle
  861. CHARACTER*(*) :: FileName
  862. INTEGER , INTENT(OUT) :: FileStatus
  863. INTEGER , INTENT(OUT) :: Status
  864. CHARACTER *80 SysDepInfo
  865. Status = 0
  866. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: begin, DataHandle = ', DataHandle
  867. CALL wrf_debug ( 5 , TRIM(msg) )
  868. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: int_valid_handle(',DataHandle,') = ', &
  869. int_valid_handle( DataHandle )
  870. CALL wrf_debug ( 5 , TRIM(msg) )
  871. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: int_handle_in_use(',DataHandle,') = ', &
  872. int_handle_in_use( DataHandle )
  873. CALL wrf_debug ( 5 , TRIM(msg) )
  874. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: opened_for_read(',DataHandle,') = ', &
  875. opened_for_read( DataHandle )
  876. CALL wrf_debug ( 5 , TRIM(msg) )
  877. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: okay_to_read(',DataHandle,') = ', &
  878. okay_to_read( DataHandle )
  879. CALL wrf_debug ( 5 , TRIM(msg) )
  880. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: opened_for_write(',DataHandle,') = ', &
  881. opened_for_write( DataHandle )
  882. CALL wrf_debug ( 5 , TRIM(msg) )
  883. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: okay_to_write(',DataHandle,') = ', &
  884. okay_to_write( DataHandle )
  885. CALL wrf_debug ( 5 , TRIM(msg) )
  886. !TODO: need to cache file name and return via FileName argument
  887. FileStatus = WRF_FILE_NOT_OPENED
  888. IF ( int_valid_handle( DataHandle ) ) THEN
  889. IF ( int_handle_in_use( DataHandle ) ) THEN
  890. IF ( opened_for_read ( DataHandle ) ) THEN
  891. IF ( okay_to_read( DataHandle ) ) THEN
  892. FileStatus = WRF_FILE_OPENED_FOR_READ
  893. ELSE
  894. FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
  895. ENDIF
  896. ELSE IF ( opened_for_write( DataHandle ) ) THEN
  897. IF ( okay_to_write( DataHandle ) ) THEN
  898. FileStatus = WRF_FILE_OPENED_FOR_WRITE
  899. ELSE
  900. FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
  901. ENDIF
  902. ELSE
  903. FileStatus = WRF_FILE_NOT_OPENED
  904. ENDIF
  905. ENDIF
  906. WRITE( msg,* ) 'ERROR ext_esmf_inquire_filename: file handle ',DataHandle,' is invalid'
  907. CALL wrf_error_fatal ( TRIM(msg) )
  908. ENDIF
  909. WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename: end, FileStatus = ', FileStatus
  910. CALL wrf_debug ( 5 , TRIM(msg) )
  911. Status = 0
  912. RETURN
  913. END SUBROUTINE ext_esmf_inquire_filename
  914. !--- sync
  915. SUBROUTINE ext_esmf_iosync ( DataHandle, Status )
  916. USE module_ext_esmf
  917. IMPLICIT NONE
  918. INTEGER , INTENT(IN) :: DataHandle
  919. INTEGER , INTENT(OUT) :: Status
  920. Status = 0
  921. RETURN
  922. END SUBROUTINE ext_esmf_iosync
  923. !--- close
  924. SUBROUTINE ext_esmf_ioclose ( DataHandle, Status )
  925. USE module_ext_esmf
  926. IMPLICIT NONE
  927. INTEGER DataHandle, Status
  928. ! locals
  929. TYPE state_ptr
  930. TYPE(ESMF_State), POINTER :: stateptr
  931. END TYPE state_ptr
  932. TYPE(state_ptr) :: states(2)
  933. TYPE(ESMF_State), POINTER :: state
  934. INTEGER :: numItems, numFields, i, istate
  935. TYPE(ESMF_StateItem_Flag), ALLOCATABLE :: itemTypes(:)
  936. TYPE(ESMF_Field) :: tmpField
  937. REAL, POINTER :: tmp_ptr(:,:)
  938. CHARACTER (len=ESMF_MAXSTR), ALLOCATABLE :: itemNames(:)
  939. CHARACTER (len=ESMF_MAXSTR) :: str
  940. INTEGER :: rc
  941. ! TODO: The code below hangs with this error message:
  942. ! TODO: "ext_esmf_ioclose: ESMF_FieldGetDataPointer( LANDMASK) failed"
  943. ! TODO: Fix this so ESMF objects actually get destroyed to avoid memory
  944. ! TODO: leaks.
  945. CALL wrf_debug( 5, 'ext_esmf_ioclose: WARNING: not destroying ESMF objects' )
  946. #if 0
  947. !TODO: Need to upgrade this to use nested ESMF_States if we want support
  948. !TODO: more than one auxin and one auxhist stream for ESMF.
  949. IF ( int_valid_handle (DataHandle) ) THEN
  950. IF ( int_handle_in_use( DataHandle ) ) THEN
  951. ! Iterate through importState *and* exportState, find each ESMF_Field,
  952. ! extract its data pointer and deallocate it, then destroy the
  953. ! ESMF_Field.
  954. CALL ESMF_ImportStateGetCurrent(states(1)%stateptr, rc)
  955. IF ( rc /= ESMF_SUCCESS ) THEN
  956. CALL wrf_error_fatal( 'ext_esmf_ioclose: ESMF_ImportStateGetCurrent failed' )
  957. ENDIF
  958. CALL ESMF_ExportStateGetCurrent(states(2)%stateptr, rc)
  959. IF ( rc /= ESMF_SUCCESS ) THEN
  960. CALL wrf_error_fatal( 'ext_esmf_ioclose: ESMF_ExportStateGetCurrent failed' )
  961. ENDIF
  962. DO istate=1, 2
  963. state => states(istate)%stateptr ! all this to avoid assignment (@#$%)
  964. ! Since there are no convenient iterators for ESMF_State (@#$%),
  965. ! write a lot of code...
  966. ! Figure out how many items are in the ESMF_State
  967. CALL ESMF_StateGet(state, itemCount=numItems, rc=rc)
  968. IF ( rc /= ESMF_SUCCESS) THEN
  969. CALL wrf_error_fatal ( 'ext_esmf_ioclose: ESMF_StateGet(numItems) failed' )
  970. ENDIF
  971. ! allocate an array to hold the types of all items
  972. ALLOCATE( itemTypes(numItems) )
  973. ! allocate an array to hold the names of all items
  974. ALLOCATE( itemNames(numItems) )
  975. ! get the item types and names
  976. !5.2.0r CALL ESMF_StateGet(state, stateitemtypeList=itemTypes, &
  977. CALL ESMF_StateGet(state, itemtypeList=itemTypes, &
  978. itemNameList=itemNames, rc=rc)
  979. IF ( rc /= ESMF_SUCCESS) THEN
  980. WRITE(str,*) 'ext_esmf_ioclose: ESMF_StateGet itemTypes failed with rc = ', rc
  981. CALL wrf_error_fatal ( str )
  982. ENDIF
  983. ! count how many items are ESMF_Fields
  984. numFields = 0
  985. DO i=1,numItems
  986. IF ( itemTypes(i) == ESMF_STATEITEM_FIELD ) THEN
  987. numFields = numFields + 1
  988. ENDIF
  989. ENDDO
  990. IF ( numFields > 0) THEN
  991. ! finally, extract nested ESMF_Fields by name, if there are any
  992. ! (should be able to do this by index at least -- @#%$)
  993. DO i=1,numItems
  994. IF ( itemTypes(i) == ESMF_STATEITEM_FIELD ) THEN
  995. CALL ESMF_StateGetField( state, TRIM(itemNames(i)), &
  996. tmpField, rc=rc )
  997. IF ( rc /= ESMF_SUCCESS) THEN
  998. WRITE(str,*) 'ext_esmf_ioclose: ESMF_StateGetField(',TRIM(itemNames(i)),') failed'
  999. CALL wrf_error_fatal ( str )
  1000. ENDIF
  1001. ! destroy pointer in field
  1002. CALL ESMF_FieldGetDataPointer( tmpField, tmp_ptr, rc=rc )
  1003. IF (rc /= ESMF_SUCCESS) THEN
  1004. WRITE( str , * ) &
  1005. 'ext_esmf_ioclose: ESMF_FieldGetDataPointer( ', &
  1006. TRIM(itemNames(i)),') failed'
  1007. CALL wrf_error_fatal ( TRIM(str) )
  1008. ENDIF
  1009. DEALLOCATE( tmp_ptr )
  1010. ! destroy field
  1011. CALL ESMF_FieldDestroy( tmpField, rc=rc )
  1012. IF (rc /= ESMF_SUCCESS) THEN
  1013. WRITE( str , * ) &
  1014. 'ext_esmf_ioclose: ESMF_FieldDestroy( ', &
  1015. TRIM(itemNames(i)),') failed'
  1016. CALL wrf_error_fatal ( TRIM(str) )
  1017. ENDIF
  1018. ENDIF
  1019. ENDDO
  1020. ENDIF
  1021. ! deallocate locals
  1022. DEALLOCATE( itemTypes )
  1023. DEALLOCATE( itemNames )
  1024. ENDDO
  1025. ! destroy ESMF_Grid associated with DataHandle
  1026. CALL ioesmf_destroy_grid( DataHandle )
  1027. ENDIF
  1028. ENDIF
  1029. #endif
  1030. Status = 0
  1031. RETURN
  1032. END SUBROUTINE ext_esmf_ioclose
  1033. !--- ioexit
  1034. SUBROUTINE ext_esmf_ioexit( Status )
  1035. USE module_ext_esmf
  1036. IMPLICIT NONE
  1037. INTEGER , INTENT(OUT) :: Status
  1038. INTEGER :: i
  1039. Status = 0
  1040. ! TODO: The code below causes ext_ncd_ioclose() to fail in the
  1041. ! TODO: SST component for reasons as-yet unknown.
  1042. ! TODO: Fix this so ESMF objects actually get destroyed to avoid memory
  1043. ! TODO: leaks.
  1044. CALL wrf_debug( 5, 'ext_esmf_ioexit: WARNING: not destroying ESMF objects' )
  1045. #if 0
  1046. DO i = 1, int_num_handles
  1047. ! close any remaining open DataHandles
  1048. CALL ext_esmf_ioclose ( i, Status )
  1049. ! destroy ESMF_Grid for this DataHandle
  1050. CALL ioesmf_destroy_grid( i )
  1051. ENDDO
  1052. CALL wrf_debug ( 5 , &
  1053. 'ext_esmf_ioexit: DEBUG: done cleaning up ESMF objects' )
  1054. #endif
  1055. RETURN
  1056. END SUBROUTINE ext_esmf_ioexit
  1057. !--- get_next_time
  1058. SUBROUTINE ext_esmf_get_next_time ( DataHandle, DateStr, Status )
  1059. USE module_ext_esmf
  1060. IMPLICIT NONE
  1061. INTEGER , INTENT(IN) :: DataHandle
  1062. CHARACTER*(*) :: DateStr
  1063. INTEGER , INTENT(OUT) :: Status
  1064. IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
  1065. CALL wrf_error_fatal("io_esmf.F90: ext_esmf_get_next_time: invalid data handle" )
  1066. ENDIF
  1067. IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
  1068. CALL wrf_error_fatal("io_esmf.F90: ext_esmf_get_next_time: DataHandle not opened" )
  1069. ENDIF
  1070. CALL wrf_debug(1, "ext_esmf_get_next_time() not supported yet")
  1071. Status = WRF_WARN_NOTSUPPORTED
  1072. RETURN
  1073. END SUBROUTINE ext_esmf_get_next_time
  1074. !--- set_time
  1075. SUBROUTINE ext_esmf_set_time ( DataHandle, DateStr, Status )
  1076. USE module_ext_esmf
  1077. IMPLICIT NONE
  1078. INTEGER , INTENT(IN) :: DataHandle
  1079. CHARACTER*(*) :: DateStr
  1080. INTEGER , INTENT(OUT) :: Status
  1081. CALL wrf_debug(1, "ext_esmf_set_time() not supported yet")
  1082. Status = WRF_WARN_NOTSUPPORTED
  1083. RETURN
  1084. END SUBROUTINE ext_esmf_set_time
  1085. !--- get_var_info
  1086. SUBROUTINE ext_esmf_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , &
  1087. DomainStart , DomainEnd , WrfType, Status )
  1088. USE module_ext_esmf
  1089. IMPLICIT NON

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