PageRenderTime 36ms CodeModel.GetById 17ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/frame/module_io.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 4109 lines | 2594 code | 288 blank | 1227 comment | 5 complexity | 9a0c386588802cefdf14e6b9e8dcc79a MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1. !WRF:DRIVER_LAYER:IO
    2. 

  2. !
    3. 

  3. #define DEBUG_LVL 500
    4. 

  4. 

  5. MODULE module_io
    6. 

  6. !<DESCRIPTION>
    7. 

  7. !<PRE>
    8. 

  8. ! WRF-specific package-independent interface to package-dependent WRF-specific
    9. 

  9. ! I/O packages.
    10. 

  10. !
    11. 

  11. ! These routines have the same names as those specified in the WRF I/O API 
    12. 

  12. ! except that:
    13. 

  13. ! - Routines defined in this file and called by users of this module have 
    14. 

  14. !   the "wrf_" prefix.  
    15. 

  15. ! - Routines defined in the I/O packages and called from routines in this 
    16. 

  16. !   file have the "ext_" prefix.  
    17. 

  17. ! - Routines called from routines in this file to initiate communication 
    18. 

  18. !   with I/O quilt servers have the "wrf_quilt_" prefix.  
    19. 

  19. !
    20. 

  20. ! See http://www.mmm.ucar.edu/wrf/WG2/software_2.0/IOAPI.doc for the latest 
    21. 

  21. ! version of the WRF I/O API.  This document includes detailed descriptions 
    22. 

  22. ! of subroutines and their arguments that are not duplicated in this file.  
    23. 

  23. !
    24. 

  24. ! We wish to be able to link to different packages depending on whether
    25. 

  25. ! the I/O is restart, initial, history, or boundary.  
    26. 

  26. !</PRE>
    27. 

  27. !</DESCRIPTION>
    28. 

  28. 

  29.   USE module_configure
    30. 

  30. 

  31.   LOGICAL :: is_inited = .FALSE.
    32. 

  32.   INTEGER, PARAMETER, PRIVATE :: MAX_WRF_IO_HANDLE = 1000
    33. 

  33.   INTEGER :: wrf_io_handles(MAX_WRF_IO_HANDLE), how_opened(MAX_WRF_IO_HANDLE) 
    34. 

  34.   LOGICAL :: for_output(MAX_WRF_IO_HANDLE), first_operation(MAX_WRF_IO_HANDLE)
    35. 

  35.   INTEGER :: filtno = 0
    36. 

  36.   LOGICAL, PRIVATE :: bdy_dist_flag = .TRUE.   ! false is old style undecomposed boundary data structs,
    37. 

  37.                                                 ! true is new style decomposed boundary data structs
    38. 

  38.                                                 ! are_bdys_distributed, bdys_are_distributed and
    39. 

  39.                                                 ! bdys_not_distributed routines access this flag
    40. 

  40.   CHARACTER*256 extradims
    41. 

  41. 

  42. !<DESCRIPTION>
    43. 

  43. !<PRE>
    44. 

  44. !
    45. 

  45. ! include the file generated from md_calls.m4 using the m4 preprocessor
    46. 

  46. ! note that this file also includes the CONTAINS declaration for the module
    47. 

  47. !
    48. 

  48. !</PRE>
    49. 

  49. !</DESCRIPTION>
    50. 

  50. #include "md_calls.inc"
    51. 

  51. 

  52. !--- registry-generated routine that gets the io format being used for a dataset
    53. 

  53. 

  54.   INTEGER FUNCTION io_form_for_dataset ( DataSet )
    55. 

  55.     IMPLICIT NONE
    56. 

  56.     CHARACTER*(*), INTENT(IN)  :: DataSet
    57. 

  57.     INTEGER                    :: io_form 
    58. 

  58. #include "io_form_for_dataset.inc"
    59. 

  59.     io_form_for_dataset = io_form
    60. 

  60.     RETURN
    61. 

  61.   END FUNCTION io_form_for_dataset
    62. 

  62. 

  63.   INTEGER FUNCTION io_form_for_stream ( stream )
    64. 

  64.     USE module_streams
    65. 

  65.     IMPLICIT NONE
    66. 

  66.     INTEGER,       INTENT(IN)  :: stream
    67. 

  67.     INTEGER                    :: io_form 
    68. 

  68. #include "io_form_for_stream.inc"
    69. 

  69.     io_form_for_stream = io_form
    70. 

  70.     RETURN
    71. 

  71.   END FUNCTION io_form_for_stream
    72. 

  72. 

  73. !--- ioinit
    74. 

  74. 

  75. SUBROUTINE wrf_ioinit( Status )
    76. 

  76. !<DESCRIPTION>
    77. 

  77. !<PRE>
    78. 

  78. ! Initialize the WRF I/O system.
    79. 

  79. !</PRE>
    80. 

  80. !</DESCRIPTION>
    81. 

  81.   IMPLICIT NONE
    82. 

  82.   INTEGER, INTENT(INOUT) :: Status
    83. 

  83. !Local
    84. 

  84.   CHARACTER(len=80) :: SysDepInfo
    85. 

  85.   INTEGER :: ierr(10), minerr, maxerr
    86. 

  86. !
    87. 

  87.   Status = 0
    88. 

  88.   ierr = 0
    89. 

  89.   SysDepInfo = " "
    90. 

  90.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioinit' )
    91. 

  91.   CALL init_io_handles    ! defined below
    92. 

  92. #ifdef NETCDF
    93. 

  93.   CALL ext_ncd_ioinit(   SysDepInfo, ierr(1) )
    94. 

  94. #endif
    95. 

  95. #ifdef INTIO
    96. 

  96.   CALL ext_int_ioinit(   SysDepInfo, ierr(2) )
    97. 

  97. #endif
    98. 

  98. #ifdef PHDF5
    99. 

  99.   CALL ext_phdf5_ioinit( SysDepInfo, ierr(3) )
    100. 

  100. #endif
    101. 

  101. #ifdef PNETCDF
    102. 

  102.   CALL ext_pnc_ioinit( SysDepInfo, ierr(3) )
    103. 

  103. #endif
    104. 

  104. #ifdef MCELIO
    105. 

  105.   CALL ext_mcel_ioinit(  SysDepInfo, ierr(4) )
    106. 

  106. #endif
    107. 

  107. #ifdef XXX
    108. 

  108.   CALL ext_xxx_ioinit(   SysDepInfo, ierr(5) )
    109. 

  109. #endif
    110. 

  110. #ifdef YYY
    111. 

  111.   CALL ext_yyy_ioinit(   SysDepInfo, ierr(6) )
    112. 

  112. #endif
    113. 

  113. #ifdef ZZZ
    114. 

  114.   CALL ext_zzz_ioinit(   SysDepInfo, ierr(7) )
    115. 

  115. #endif
    116. 

  116. #ifdef ESMFIO
    117. 

  117.   CALL ext_esmf_ioinit(  SysDepInfo, ierr(8) )
    118. 

  118. #endif
    119. 

  119. #ifdef GRIB1
    120. 

  120.   CALL ext_gr1_ioinit(   SysDepInfo, ierr(9) )
    121. 

  121. #endif
    122. 

  122. #ifdef GRIB2
    123. 

  123.   CALL ext_gr2_ioinit(   SysDepInfo, ierr(10) )
    124. 

  124. #endif
    125. 

  125.   minerr = MINVAL(ierr)
    126. 

  126.   maxerr = MAXVAL(ierr)
    127. 

  127.   IF ( minerr < 0 ) THEN
    128. 

  128.     Status = minerr
    129. 

  129.   ELSE IF ( maxerr > 0 ) THEN
    130. 

  130.     Status = maxerr
    131. 

  131.   ELSE
    132. 

  132.     Status = 0
    133. 

  133.   ENDIF
    134. 

  134. END SUBROUTINE wrf_ioinit
    135. 

  135. 

  136. !--- ioexit
    137. 

  137. 

  138. SUBROUTINE wrf_ioexit( Status )
    139. 

  139. !<DESCRIPTION>
    140. 

  140. !<PRE>
    141. 

  141. ! Shut down the WRF I/O system.  
    142. 

  142. !</PRE>
    143. 

  143. !</DESCRIPTION>
    144. 

  144.   IMPLICIT NONE
    145. 

  145.   INTEGER, INTENT(INOUT) :: Status
    146. 

  146. !Local
    147. 

  147.   LOGICAL, EXTERNAL :: use_output_servers
    148. 

  148.   INTEGER :: ierr(11), minerr, maxerr
    149. 

  149. !
    150. 

  150.   Status = 0
    151. 

  151.   ierr = 0
    152. 

  152.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioexit' )
    153. 

  153. #ifdef NETCDF
    154. 

  154.   CALL ext_ncd_ioexit(  ierr(1) )
    155. 

  155. #endif
    156. 

  156. #ifdef INTIO
    157. 

  157.   CALL ext_int_ioexit(  ierr(2) )
    158. 

  158. #endif
    159. 

  159. #ifdef PHDF5
    160. 

  160.   CALL ext_phdf5_ioexit(ierr(3) )
    161. 

  161. #endif
    162. 

  162. #ifdef PNETCDF
    163. 

  163.   CALL ext_pnc_ioexit(ierr(3) )
    164. 

  164. #endif
    165. 

  165. #ifdef MCELIO
    166. 

  166.   CALL ext_mcel_ioexit( ierr(4) )
    167. 

  167. #endif
    168. 

  168. #ifdef XXX
    169. 

  169.   CALL ext_xxx_ioexit(  ierr(5) )
    170. 

  170. #endif
    171. 

  171. #ifdef YYY
    172. 

  172.   CALL ext_yyy_ioexit(  ierr(6) )
    173. 

  173. #endif
    174. 

  174. #ifdef ZZZ
    175. 

  175.   CALL ext_zzz_ioexit(  ierr(7) )
    176. 

  176. #endif
    177. 

  177. #ifdef ESMFIO
    178. 

  178.   CALL ext_esmf_ioexit( ierr(8) )
    179. 

  179. #endif
    180. 

  180. #ifdef GRIB1
    181. 

  181.   CALL ext_gr1_ioexit(  ierr(9) )
    182. 

  182. #endif
    183. 

  183. #ifdef GRIB2
    184. 

  184.   CALL ext_gr2_ioexit(  ierr(10) )
    185. 

  185. #endif
    186. 

  186.  
    187. 

  187.   IF ( use_output_servers() ) CALL wrf_quilt_ioexit( ierr(11) )
    188. 

  188.   minerr = MINVAL(ierr)
    189. 

  189.   maxerr = MAXVAL(ierr)
    190. 

  190.   IF ( minerr < 0 ) THEN
    191. 

  191.     Status = minerr
    192. 

  192.   ELSE IF ( maxerr > 0 ) THEN
    193. 

  193.     Status = maxerr
    194. 

  194.   ELSE
    195. 

  195.     Status = 0
    196. 

  196.   ENDIF
    197. 

  197. END SUBROUTINE wrf_ioexit
    198. 

  198. 

  199. !--- open_for_write_begin
    200. 

  200. 

  201. SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
    202. 

  202.                                      DataHandle , Status )
    203. 

  203. !<DESCRIPTION>
    204. 

  204. !<PRE>
    205. 

  205. ! Begin data definition ("training") phase for writing to WRF dataset 
    206. 

  206. ! FileName.  
    207. 

  207. !</PRE>
    208. 

  208. !</DESCRIPTION>
    209. 

  209.   USE module_state_description
    210. 

  210. #ifdef DM_PARALLEL
    211. 

  211.   USE module_dm, ONLY :  ntasks_x, mytask_x, local_communicator_x
    212. 

  212. #endif
    213. 

  213.   IMPLICIT NONE
    214. 

  214. #include "wrf_io_flags.h"
    215. 

  215.   CHARACTER*(*) :: FileName
    216. 

  216.   INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
    217. 

  217.   CHARACTER*(*), INTENT(INOUT):: SysDepInfo
    218. 

  218.   INTEGER ,       INTENT(OUT) :: DataHandle
    219. 

  219.   INTEGER ,       INTENT(OUT) :: Status
    220. 

  220.  !Local 
    221. 

  221.   CHARACTER*128               :: DataSet
    222. 

  222.   INTEGER                     :: io_form
    223. 

  223.   INTEGER                     :: Hndl
    224. 

  224.   INTEGER, EXTERNAL           :: use_package
    225. 

  225.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    226. 

  226.   CHARACTER*128     :: LocFilename   ! for appending the process ID if necessary
    227. 

  227.   INTEGER           :: myproc
    228. 

  228.   CHARACTER*128     :: mess
    229. 

  229.   CHARACTER*1028    :: tstr, t1
    230. 

  230.   INTEGER i,j
    231. 

  231. 

  232.   WRITE(mess,*) 'module_io.F: in wrf_open_for_write_begin, FileName = ',TRIM(FileName)
    233. 

  233.   CALL wrf_debug( DEBUG_LVL, mess )
    234. 

  234. 

  235.   CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet )
    236. 

  236. 

  237.   io_form = io_form_for_dataset( DataSet )
    238. 

  238. 

  239.   Status = 0
    240. 

  240.   Hndl = -1
    241. 

  241.   IF ( multi_files( io_form ) .OR. .NOT. use_output_servers() ) THEN
    242. 

  242.     SELECT CASE ( use_package(io_form) )
    243. 

  243. #ifdef NETCDF
    244. 

  244.       CASE ( IO_NETCDF   )
    245. 

  245.         IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
    246. 

  246.           IF ( multi_files(io_form) ) THEN
    247. 

  247.             CALL wrf_get_myproc ( myproc )
    248. 

  248.             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
    249. 

  249.           ELSE
    250. 

  250.             LocFilename = FileName
    251. 

  251.           ENDIF
    252. 

  252.           CALL ext_ncd_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
    253. 

  253.                                               Hndl , Status )
    254. 

  254.         ENDIF
    255. 

  255.         IF ( .NOT. multi_files(io_form) ) THEN
    256. 

  256.           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    257. 

  257.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    258. 

  258.         ENDIF
    259. 

  259. #endif
    260. 

  260. #ifdef PHDF5
    261. 

  261.       CASE (IO_PHDF5  )
    262. 

  262.         CALL ext_phdf5_open_for_write_begin( FileName, Comm_compute, Comm_io, SysDepInfo, &
    263. 

  263.                                             Hndl, Status)
    264. 

  264. #endif
    265. 

  265. #ifdef PNETCDF
    266. 

  266.       CASE (IO_PNETCDF  )
    267. 

  267.         WRITE(tstr,"(A,',NTASKS_X=',i10,',MYTASK_X=',i10,',LOCAL_COMMUNICATOR_X=',i10)") TRIM(SysDepInfo),ntasks_x,mytask_x,local_communicator_x
    268. 

  268.         j=1
    269. 

  269.         t1 = " "
    270. 

  270.         DO i=1,len(TRIM(tstr))
    271. 

  271.           IF ( tstr(i:i) .NE. ' ' ) THEN
    272. 

  272.             t1(j:j) = tstr(i:i)
    273. 

  273.             j = j + 1
    274. 

  274.           ENDIF
    275. 

  275.         ENDDO
    276. 

  276.         tstr = t1
    277. 

  277.         CALL ext_pnc_open_for_write_begin( FileName, Comm_compute, Comm_io, tstr, &
    278. 

  278.                                             Hndl, Status)
    279. 

  279. #endif
    280. 

  280. #ifdef XXX
    281. 

  281.       CASE ( IO_XXX   )
    282. 

  282.         CALL ext_xxx_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    283. 

  283.                                             Hndl , Status )
    284. 

  284. #endif
    285. 

  285. #ifdef YYY
    286. 

  286.       CASE ( IO_YYY   )
    287. 

  287.         IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
    288. 

  288.           IF ( multi_files(io_form) ) THEN
    289. 

  289.             CALL wrf_get_myproc ( myproc )
    290. 

  290.             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
    291. 

  291.           ELSE
    292. 

  292.             LocFilename = FileName
    293. 

  293.           ENDIF
    294. 

  294.           CALL ext_yyy_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
    295. 

  295.                                               Hndl , Status )
    296. 

  296.         ENDIF
    297. 

  297.         IF ( .NOT. multi_files(io_form) ) THEN
    298. 

  298.           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    299. 

  299.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    300. 

  300.         ENDIF
    301. 

  301. #endif
    302. 

  302. #ifdef ZZZ
    303. 

  303.       CASE ( IO_ZZZ   )
    304. 

  304.         CALL ext_zzz_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    305. 

  305.                                             Hndl , Status )
    306. 

  306. #endif
    307. 

  307. #ifdef GRIB1
    308. 

  308.       CASE ( IO_GRIB1   )
    309. 

  309.         IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
    310. 

  310.           IF ( multi_files(io_form) ) THEN
    311. 

  311.             CALL wrf_get_myproc ( myproc )
    312. 

  312.             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
    313. 

  313.           ELSE
    314. 

  314.             LocFilename = FileName
    315. 

  315.           ENDIF
    316. 

  316.           CALL ext_gr1_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
    317. 

  317.                                               Hndl , Status )
    318. 

  318.         ENDIF
    319. 

  319.         IF ( .NOT. multi_files(io_form) ) THEN
    320. 

  320.           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    321. 

  321.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    322. 

  322.         ENDIF
    323. 

  323. #endif
    324. 

  324. #ifdef GRIB2
    325. 

  325.       CASE ( IO_GRIB2   )
    326. 

  326.         IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
    327. 

  327.           IF ( multi_files(io_form) ) THEN
    328. 

  328.             CALL wrf_get_myproc ( myproc )
    329. 

  329.             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
    330. 

  330.           ELSE
    331. 

  331.             LocFilename = FileName
    332. 

  332.           ENDIF
    333. 

  333.           CALL ext_gr2_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
    334. 

  334.                                               Hndl , Status )
    335. 

  335.         ENDIF
    336. 

  336.         IF ( .NOT. multi_files(io_form) ) THEN
    337. 

  337.           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    338. 

  338.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    339. 

  339.         ENDIF
    340. 

  340. #endif
    341. 

  341. #ifdef MCELIO
    342. 

  342.       CASE ( IO_MCEL )
    343. 

  343.         IF ( wrf_dm_on_monitor() ) THEN
    344. 

  344.           tstr = TRIM(SysDepInfo) // ',' // 'LAT_R=XLAT,LON_R=XLONG,LANDMASK_I=LU_MASK'
    345. 

  345.           CALL ext_mcel_open_for_write_begin ( FileName , Comm_compute, Comm_io, tstr, &
    346. 

  346.                                                Hndl , Status )
    347. 

  347.         ENDIF
    348. 

  348.         CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    349. 

  349.         CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    350. 

  350. #endif
    351. 

  351. #ifdef ESMFIO
    352. 

  352.       CASE ( IO_ESMF )
    353. 

  353.         CALL ext_esmf_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    354. 

  354.                                              Hndl , Status )
    355. 

  355. #endif
    356. 

  356. #ifdef INTIO
    357. 

  357.       CASE ( IO_INTIO   )
    358. 

  358.         IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
    359. 

  359.           IF ( multi_files(io_form) ) THEN
    360. 

  360.             CALL wrf_get_myproc ( myproc )
    361. 

  361.             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
    362. 

  362.           ELSE
    363. 

  363.             LocFilename = FileName
    364. 

  364.           ENDIF
    365. 

  365.           CALL ext_int_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
    366. 

  366.                                               Hndl , Status )
    367. 

  367.         ENDIF
    368. 

  368.         IF ( .NOT. multi_files(io_form) ) THEN
    369. 

  369.           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    370. 

  370.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    371. 

  371.         ENDIF
    372. 

  372. #endif
    373. 

  373.       CASE DEFAULT
    374. 

  374.         IF ( io_form .NE. 0 ) THEN
    375. 

  375.           WRITE(mess,*)'Tried to open ',FileName,' writing: no valid io_form (',io_form,')'
    376. 

  376.           CALL wrf_debug(1, mess)
    377. 

  377.           Status = WRF_FILE_NOT_OPENED
    378. 

  378.         ENDIF
    379. 

  379.     END SELECT
    380. 

  380.   ELSE IF ( use_output_servers() ) THEN
    381. 

  381.     IF ( io_form .GT. 0 ) THEN
    382. 

  382.       CALL wrf_quilt_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    383. 

  383.                                             Hndl , io_form, Status )
    384. 

  384.     ENDIF
    385. 

  385.   ELSE
    386. 

  386.     Status = 0
    387. 

  387.   ENDIF
    388. 

  388.   CALL add_new_handle( Hndl, io_form, .TRUE., DataHandle )
    389. 

  389. END SUBROUTINE wrf_open_for_write_begin
    390. 

  390. 

  391. !--- open_for_write_commit
    392. 

  392. 

  393. SUBROUTINE wrf_open_for_write_commit( DataHandle , Status )
    394. 

  394. !<DESCRIPTION>
    395. 

  395. !<PRE>
    396. 

  396. ! This routine switches an internal flag to enable output for the data set 
    397. 

  397. ! referenced by DataHandle. The call to wrf_open_for_write_commit() must be 
    398. 

  398. ! paired with a call to wrf_open_for_write_begin().
    399. 

  399. !</PRE>
    400. 

  400. !</DESCRIPTION>
    401. 

  401.   USE module_state_description
    402. 

  402.   IMPLICIT NONE
    403. 

  403.   INTEGER ,       INTENT(IN ) :: DataHandle
    404. 

  404.   INTEGER ,       INTENT(OUT) :: Status
    405. 

  405.  
    406. 

  406.   CHARACTER (128)             :: DataSet
    407. 

  407.   INTEGER                     :: io_form
    408. 

  408.   INTEGER                     :: Hndl
    409. 

  409.   LOGICAL                     :: for_out
    410. 

  410.   INTEGER, EXTERNAL           :: use_package
    411. 

  411.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    412. 

  412. #include "wrf_io_flags.h"
    413. 

  413. 

  414.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_write_commit' )
    415. 

  415. 

  416.   Status = 0
    417. 

  417.   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
    418. 

  418.   CALL set_first_operation( DataHandle )
    419. 

  419.   IF ( Hndl .GT. -1 ) THEN
    420. 

  420.     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
    421. 

  421.       SELECT CASE ( use_package(io_form) )
    422. 

  422. #ifdef NETCDF
    423. 

  423.         CASE ( IO_NETCDF   )
    424. 

  424.           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
    425. 

  425.             CALL ext_ncd_open_for_write_commit ( Hndl , Status )
    426. 

  426.           ENDIF
    427. 

  427.           IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    428. 

  428. #endif
    429. 

  429. #ifdef MCELIO
    430. 

  430.         CASE ( IO_MCEL   )
    431. 

  431.           IF ( wrf_dm_on_monitor() ) THEN
    432. 

  432.             CALL ext_mcel_open_for_write_commit ( Hndl , Status )
    433. 

  433.           ENDIF
    434. 

  434.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    435. 

  435. #endif
    436. 

  436. #ifdef ESMFIO
    437. 

  437.         CASE ( IO_ESMF )
    438. 

  438.           CALL ext_esmf_open_for_write_commit ( Hndl , Status )
    439. 

  439. #endif
    440. 

  440. #ifdef PHDF5
    441. 

  441.       CASE ( IO_PHDF5  )
    442. 

  442.         CALL ext_phdf5_open_for_write_commit ( Hndl , Status )
    443. 

  443. #endif
    444. 

  444. #ifdef PNETCDF
    445. 

  445.       CASE ( IO_PNETCDF  )
    446. 

  446.         CALL ext_pnc_open_for_write_commit ( Hndl , Status )
    447. 

  447. #endif
    448. 

  448. #ifdef XXX
    449. 

  449.       CASE ( IO_XXX   )
    450. 

  450.         CALL ext_xxx_open_for_write_commit ( Hndl , Status )
    451. 

  451. #endif
    452. 

  452. #ifdef YYY
    453. 

  453.       CASE ( IO_YYY   )
    454. 

  454.          IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
    455. 

  455.             CALL ext_yyy_open_for_write_commit ( Hndl , Status )
    456. 

  456.          ENDIF
    457. 

  457.          IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    458. 

  458. #endif
    459. 

  459. #ifdef ZZZ
    460. 

  460.       CASE ( IO_ZZZ   )
    461. 

  461.         CALL ext_zzz_open_for_write_commit ( Hndl , Status )
    462. 

  462. #endif
    463. 

  463. #ifdef GRIB1
    464. 

  464.       CASE ( IO_GRIB1   )
    465. 

  465.          IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
    466. 

  466.             CALL ext_gr1_open_for_write_commit ( Hndl , Status )
    467. 

  467.          ENDIF
    468. 

  468.          IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    469. 

  469. #endif
    470. 

  470. #ifdef GRIB2
    471. 

  471.       CASE ( IO_GRIB2   )
    472. 

  472.          IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
    473. 

  473.             CALL ext_gr2_open_for_write_commit ( Hndl , Status )
    474. 

  474.          ENDIF
    475. 

  475.          IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    476. 

  476. #endif
    477. 

  477. #ifdef INTIO
    478. 

  478.       CASE ( IO_INTIO   )
    479. 

  479.         CALL ext_int_open_for_write_commit ( Hndl , Status )
    480. 

  480. #endif
    481. 

  481.         CASE DEFAULT
    482. 

  482.           Status = 0
    483. 

  483.       END SELECT
    484. 

  484.     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
    485. 

  485.       CALL wrf_quilt_open_for_write_commit ( Hndl , Status )
    486. 

  486.     ELSE
    487. 

  487.       Status = 0
    488. 

  488.     ENDIF
    489. 

  489.   ELSE
    490. 

  490.     Status = 0
    491. 

  491.   ENDIF
    492. 

  492.   RETURN
    493. 

  493. END SUBROUTINE wrf_open_for_write_commit
    494. 

  494. 

  495. !--- open_for_read_begin
    496. 

  496. 

  497. SUBROUTINE wrf_open_for_read_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
    498. 

  498.                                      DataHandle , Status )
    499. 

  499. !<DESCRIPTION>
    500. 

  500. !<PRE>
    501. 

  501. ! Begin data definition ("training") phase for reading from WRF dataset 
    502. 

  502. ! FileName.  
    503. 

  503. !</PRE>
    504. 

  504. !</DESCRIPTION>
    505. 

  505.   USE module_state_description
    506. 

  506.   IMPLICIT NONE
    507. 

  507. #include "wrf_io_flags.h"
    508. 

  508.   CHARACTER*(*) :: FileName
    509. 

  509.   INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
    510. 

  510.   CHARACTER*(*) :: SysDepInfo
    511. 

  511.   INTEGER ,       INTENT(OUT) :: DataHandle
    512. 

  512.   INTEGER ,       INTENT(OUT) :: Status
    513. 

  513.   
    514. 

  514.   CHARACTER*128               :: DataSet
    515. 

  515.   INTEGER                     :: io_form
    516. 

  516.   INTEGER                     :: Hndl
    517. 

  517.   LOGICAL                     :: also_for_out
    518. 

  518.   INTEGER, EXTERNAL           :: use_package
    519. 

  519.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    520. 

  520. 

  521.   CHARACTER*128     :: LocFilename   ! for appending the process ID if necessary
    522. 

  522.   INTEGER     myproc
    523. 

  523.   CHARACTER*128     :: mess, fhand
    524. 

  524.   CHARACTER*1028    :: tstr
    525. 

  525. 

  526.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read_begin' )
    527. 

  527. 

  528.   CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet )
    529. 

  529. 

  530.   io_form = io_form_for_dataset( DataSet )
    531. 

  531. 

  532.   Status = 0
    533. 

  533.   Hndl = -1
    534. 

  534.   also_for_out = .FALSE.
    535. 

  535. !  IF ( .NOT. use_output_servers() ) THEN
    536. 

  536.     SELECT CASE ( use_package(io_form) )
    537. 

  537. #ifdef NETCDF
    538. 

  538.       CASE ( IO_NETCDF   )
    539. 

  539.         IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
    540. 

  540.           IF ( multi_files(io_form) ) THEN
    541. 

  541.               CALL wrf_get_myproc ( myproc )
    542. 

  542.               CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
    543. 

  543.           ELSE
    544. 

  544.               LocFilename = FileName
    545. 

  545.           ENDIF
    546. 

  546.           CALL ext_ncd_open_for_read_begin ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
    547. 

  547.                                        Hndl , Status )
    548. 

  548.         ENDIF
    549. 

  549.         IF ( .NOT. multi_files(io_form) ) THEN
    550. 

  550.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    551. 

  551.           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    552. 

  552.         ENDIF
    553. 

  553. #endif
    554. 

  554. #ifdef PNETCDF
    555. 

  555.       CASE ( IO_PNETCDF   )
    556. 

  556.         CALL ext_pnc_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    557. 

  557.                                             Hndl , Status )
    558. 

  558. #endif
    559. 

  559. #ifdef XXX
    560. 

  560.       CASE ( IO_XXX   )
    561. 

  561.         CALL ext_xxx_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    562. 

  562.                                             Hndl , Status )
    563. 

  563. #endif
    564. 

  564. #ifdef YYY
    565. 

  565.       CASE ( IO_YYY   )
    566. 

  566.         CALL ext_yyy_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    567. 

  567.                                             Hndl , Status )
    568. 

  568. #endif
    569. 

  569. #ifdef ZZZ
    570. 

  570.       CASE ( IO_ZZZ   )
    571. 

  571.         CALL ext_zzz_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    572. 

  572.                                             Hndl , Status )
    573. 

  573. #endif
    574. 

  574. #ifdef MCELIO
    575. 

  575.       CASE ( IO_MCEL )
    576. 

  576.         also_for_out = .TRUE.
    577. 

  577.         IF ( wrf_dm_on_monitor() ) THEN
    578. 

  578.           
    579. 

  579.         WRITE(fhand,'(a,i0)')"filter_",filtno
    580. 

  580.         filtno = filtno + 1
    581. 

  581. tstr = TRIM(SysDepInfo) // ',' // 'READ_MODE=UPDATE,LAT_R=XLAT,LON_R=XLONG,LANDMASK_I=LU_MASK,FILTER_HANDLE=' // TRIM(fhand)
    582. 

  582.           CALL ext_mcel_open_for_read_begin ( FileName , Comm_compute, Comm_io, tstr, &
    583. 

  583.                                                Hndl , Status )
    584. 

  584.         ENDIF
    585. 

  585.         CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    586. 

  586.         CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    587. 

  587. #endif
    588. 

  588. #ifdef ESMFIO
    589. 

  589.       CASE ( IO_ESMF )
    590. 

  590.         also_for_out = .TRUE.
    591. 

  591.         CALL ext_esmf_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    592. 

  592.                                             Hndl , Status )
    593. 

  593. #endif
    594. 

  594. #ifdef GRIB1
    595. 

  595.       CASE ( IO_GRIB1   )
    596. 

  596.         IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
    597. 

  597.           IF ( multi_files(io_form) ) THEN
    598. 

  598.               CALL wrf_get_myproc ( myproc )
    599. 

  599.               CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
    600. 

  600.           ELSE
    601. 

  601.               LocFilename = FileName
    602. 

  602.           ENDIF
    603. 

  603.           CALL ext_gr1_open_for_read_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
    604. 

  604.                Hndl , Status )
    605. 

  605.         ENDIF
    606. 

  606.         IF ( .NOT. multi_files(io_form) ) THEN
    607. 

  607.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    608. 

  608.           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    609. 

  609.         ENDIF
    610. 

  610. #endif
    611. 

  611. #ifdef GRIB2
    612. 

  612.       CASE ( IO_GRIB2   )
    613. 

  613.         IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
    614. 

  614.           IF ( multi_files(io_form) ) THEN
    615. 

  615.               CALL wrf_get_myproc ( myproc )
    616. 

  616.               CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
    617. 

  617.           ELSE
    618. 

  618.               LocFilename = FileName
    619. 

  619.           ENDIF
    620. 

  620.           CALL ext_gr2_open_for_read_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
    621. 

  621.                Hndl , Status )
    622. 

  622.         ENDIF
    623. 

  623.         IF ( .NOT. multi_files(io_form) ) THEN
    624. 

  624.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    625. 

  625.           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    626. 

  626.         ENDIF
    627. 

  627. #endif
    628. 

  628. #ifdef INTIO
    629. 

  629.       CASE ( IO_INTIO   )
    630. 

  630. #endif
    631. 

  631.       CASE DEFAULT
    632. 

  632.         IF ( io_form .NE. 0 ) THEN
    633. 

  633.           WRITE(mess,*)'Tried to open ',FileName,' reading: no valid io_form (',io_form,')'
    634. 

  634.           CALL wrf_message(mess)
    635. 

  635.         ENDIF
    636. 

  636.         Status = WRF_FILE_NOT_OPENED
    637. 

  637.     END SELECT
    638. 

  638. !  ELSE
    639. 

  639. !    Status = 0
    640. 

  640. !  ENDIF
    641. 

  641.   CALL add_new_handle( Hndl, io_form, also_for_out, DataHandle )
    642. 

  642. END SUBROUTINE wrf_open_for_read_begin
    643. 

  643. 

  644. !--- open_for_read_commit
    645. 

  645. 

  646. SUBROUTINE wrf_open_for_read_commit( DataHandle , Status )
    647. 

  647. !<DESCRIPTION>
    648. 

  648. !<PRE>
    649. 

  649. ! End "training" phase for WRF dataset FileName.  The call to 
    650. 

  650. ! wrf_open_for_read_commit() must be paired with a call to 
    651. 

  651. ! wrf_open_for_read_begin().
    652. 

  652. !</PRE>
    653. 

  653. !</DESCRIPTION>
    654. 

  654.   USE module_state_description
    655. 

  655.   IMPLICIT NONE
    656. 

  656.   INTEGER ,       INTENT(IN ) :: DataHandle
    657. 

  657.   INTEGER ,       INTENT(OUT) :: Status
    658. 

  658.  
    659. 

  659.   CHARACTER (128)             :: DataSet
    660. 

  660.   INTEGER                     :: io_form
    661. 

  661.   INTEGER                     :: Hndl
    662. 

  662.   LOGICAL                     :: for_out
    663. 

  663.   INTEGER, EXTERNAL           :: use_package
    664. 

  664.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    665. 

  665. #include "wrf_io_flags.h"
    666. 

  666. 

  667.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read_commit' )
    668. 

  668. 

  669.   Status = 0
    670. 

  670.   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
    671. 

  671.   CALL set_first_operation( DataHandle )
    672. 

  672.   IF ( Hndl .GT. -1 ) THEN
    673. 

  673.     IF ( .NOT. (for_out .AND. use_output_servers()) ) THEN
    674. 

  674.       SELECT CASE ( use_package(io_form) )
    675. 

  675. #ifdef NETCDF
    676. 

  676.         CASE ( IO_NETCDF   )
    677. 

  677.           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
    678. 

  678.             CALL ext_ncd_open_for_read_commit ( Hndl , Status )
    679. 

  679.           ENDIF
    680. 

  680.           IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    681. 

  681. #endif
    682. 

  682. #ifdef MCELIO
    683. 

  683.         CASE ( IO_MCEL   )
    684. 

  684.           IF ( wrf_dm_on_monitor() ) THEN
    685. 

  685.             CALL ext_mcel_open_for_read_commit ( Hndl , Status )
    686. 

  686.           ENDIF
    687. 

  687.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    688. 

  688. #endif
    689. 

  689. #ifdef ESMFIO
    690. 

  690.         CASE ( IO_ESMF )
    691. 

  691.           CALL ext_esmf_open_for_read_commit ( Hndl , Status )
    692. 

  692. #endif
    693. 

  693. #ifdef PNETCDF
    694. 

  694.         CASE ( IO_PNETCDF )
    695. 

  695.           CALL ext_pnc_open_for_read_commit ( Hndl , Status )
    696. 

  696. #endif
    697. 

  697. #ifdef XXX
    698. 

  698.       CASE ( IO_XXX   )
    699. 

  699.         CALL ext_xxx_open_for_read_commit ( Hndl , Status )
    700. 

  700. #endif
    701. 

  701. #ifdef YYY
    702. 

  702.       CASE ( IO_YYY   )
    703. 

  703.         CALL ext_yyy_open_for_read_commit ( Hndl , Status )
    704. 

  704. #endif
    705. 

  705. #ifdef ZZZ
    706. 

  706.       CASE ( IO_ZZZ   )
    707. 

  707.         CALL ext_zzz_open_for_read_commit ( Hndl , Status )
    708. 

  708. #endif
    709. 

  709. #ifdef GRIB1
    710. 

  710.       CASE ( IO_GRIB1   )
    711. 

  711.         CALL ext_gr1_open_for_read_commit ( Hndl , Status )
    712. 

  712. #endif
    713. 

  713. #ifdef GRIB2
    714. 

  714.       CASE ( IO_GRIB2   )
    715. 

  715.         CALL ext_gr2_open_for_read_commit ( Hndl , Status )
    716. 

  716. #endif
    717. 

  717. #ifdef INTIO
    718. 

  718.       CASE ( IO_INTIO   )
    719. 

  719. #endif
    720. 

  720.         CASE DEFAULT
    721. 

  721.           Status = 0
    722. 

  722.       END SELECT
    723. 

  723.     ELSE
    724. 

  724.       Status = 0
    725. 

  725.     ENDIF
    726. 

  726.   ELSE
    727. 

  727.     Status = WRF_FILE_NOT_OPENED
    728. 

  728.   ENDIF
    729. 

  729.   RETURN
    730. 

  730. END SUBROUTINE wrf_open_for_read_commit
    731. 

  731. 

  732. !--- open_for_read 
    733. 

  733. 

  734. SUBROUTINE wrf_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    735. 

  735.                                DataHandle , Status )
    736. 

  736. !<DESCRIPTION>
    737. 

  737. !<PRE>
    738. 

  738. ! Opens a WRF dataset for reading.  
    739. 

  739. !</PRE>
    740. 

  740. !</DESCRIPTION>
    741. 

  741.   USE module_state_description
    742. 

  742.   IMPLICIT NONE
    743. 

  743.   CHARACTER*(*) :: FileName
    744. 

  744.   INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
    745. 

  745.   CHARACTER*(*) :: SysDepInfo
    746. 

  746.   INTEGER ,       INTENT(OUT) :: DataHandle
    747. 

  747.   INTEGER ,       INTENT(OUT) :: Status
    748. 

  748. 

  749.   CHARACTER (128)             :: DataSet, LocFileName
    750. 

  750.   INTEGER                     :: io_form, myproc
    751. 

  751.   INTEGER                     :: Hndl
    752. 

  752.   INTEGER, EXTERNAL           :: use_package
    753. 

  753.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    754. 

  754. 

  755.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read' )
    756. 

  756. 

  757.   CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet )
    758. 

  758. 

  759.   io_form = io_form_for_dataset( DataSet )
    760. 

  760. 

  761.   Hndl = -1
    762. 

  762.   Status = 0
    763. 

  763.   SELECT CASE ( use_package(io_form) )
    764. 

  764. #ifdef NETCDF
    765. 

  765.     CASE ( IO_NETCDF   )
    766. 

  766.       IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
    767. 

  767.         IF ( multi_files(io_form) ) THEN
    768. 

  768.             CALL wrf_get_myproc ( myproc )
    769. 

  769.             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
    770. 

  770.         ELSE
    771. 

  771.             LocFilename = FileName
    772. 

  772.         ENDIF
    773. 

  773. 

  774.         CALL ext_ncd_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
    775. 

  775.                                      Hndl , Status )
    776. 

  776.       ENDIF
    777. 

  777.       IF ( .NOT. multi_files(io_form) ) THEN
    778. 

  778.         CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    779. 

  779.         CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    780. 

  780.       ENDIF
    781. 

  781. #endif
    782. 

  782. #ifdef PNETCDF
    783. 

  783.     CASE ( IO_PNETCDF  )
    784. 

  784.       CALL ext_pnc_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    785. 

  785.                                Hndl , Status )
    786. 

  786. #endif
    787. 

  787. #ifdef PHDF5
    788. 

  788.     CASE ( IO_PHDF5  )
    789. 

  789.       CALL ext_phdf5_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    790. 

  790.                                Hndl , Status )
    791. 

  791. #endif
    792. 

  792. #ifdef XXX
    793. 

  793.     CASE ( IO_XXX   )
    794. 

  794.       CALL ext_xxx_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    795. 

  795.                                Hndl , Status )
    796. 

  796. #endif
    797. 

  797. #ifdef YYY
    798. 

  798.     CASE ( IO_YYY   )
    799. 

  799.       IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
    800. 

  800.         IF ( multi_files(io_form) ) THEN
    801. 

  801.             CALL wrf_get_myproc ( myproc )
    802. 

  802.             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
    803. 

  803.         ELSE
    804. 

  804.             LocFilename = FileName
    805. 

  805.         ENDIF
    806. 

  806. 

  807.         CALL ext_yyy_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
    808. 

  808.                                      Hndl , Status )
    809. 

  809.       ENDIF
    810. 

  810.       IF ( .NOT. multi_files(io_form) ) THEN
    811. 

  811.         CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    812. 

  812.         CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    813. 

  813.       ENDIF
    814. 

  814. #endif
    815. 

  815. #ifdef ZZZ
    816. 

  816.     CASE ( IO_ZZZ   )
    817. 

  817.       CALL ext_zzz_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
    818. 

  818.                                Hndl , Status )
    819. 

  819. #endif
    820. 

  820. #ifdef GRIB1
    821. 

  821.     CASE ( IO_GRIB1   )
    822. 

  822.       IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
    823. 

  823.         IF ( multi_files(io_form) ) THEN
    824. 

  824.             CALL wrf_get_myproc ( myproc )
    825. 

  825.             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
    826. 

  826.         ELSE
    827. 

  827.             LocFilename = FileName
    828. 

  828.         ENDIF
    829. 

  829. 

  830.         CALL ext_gr1_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
    831. 

  831.                                      Hndl , Status )
    832. 

  832.       ENDIF
    833. 

  833.       IF ( .NOT. multi_files(io_form) ) THEN
    834. 

  834.         CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    835. 

  835.         CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    836. 

  836.       ENDIF
    837. 

  837. #endif
    838. 

  838. #ifdef GRIB2
    839. 

  839.     CASE ( IO_GRIB2   )
    840. 

  840.       IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
    841. 

  841.         IF ( multi_files(io_form) ) THEN
    842. 

  842.             CALL wrf_get_myproc ( myproc )
    843. 

  843.             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
    844. 

  844.         ELSE
    845. 

  845.             LocFilename = FileName
    846. 

  846.         ENDIF
    847. 

  847. 

  848.         CALL ext_gr2_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
    849. 

  849.                                      Hndl , Status )
    850. 

  850.       ENDIF
    851. 

  851.       IF ( .NOT. multi_files(io_form) ) THEN
    852. 

  852.         CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    853. 

  853.         CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    854. 

  854.       ENDIF
    855. 

  855. #endif
    856. 

  856. #ifdef INTIO
    857. 

  857.     CASE ( IO_INTIO   )
    858. 

  858.       IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
    859. 

  859.         IF ( multi_files(io_form) ) THEN
    860. 

  860.             CALL wrf_get_myproc ( myproc )
    861. 

  861.             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
    862. 

  862.         ELSE
    863. 

  863.             LocFilename = FileName
    864. 

  864.         ENDIF
    865. 

  865.         CALL ext_int_open_for_read ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
    866. 

  866.                                      Hndl , Status )
    867. 

  867.       ENDIF
    868. 

  868.       IF ( .NOT. multi_files(io_form) ) THEN
    869. 

  869.         CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    870. 

  870.         CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
    871. 

  871.       ENDIF
    872. 

  872. #endif
    873. 

  873.     CASE DEFAULT
    874. 

  874.         Status = 0
    875. 

  875.   END SELECT
    876. 

  876.   CALL add_new_handle( Hndl, io_form, .FALSE., DataHandle )
    877. 

  877.   RETURN  
    878. 

  878. END SUBROUTINE wrf_open_for_read
    879. 

  879. 

  880. !--- inquire_opened
    881. 

  881. 

  882. SUBROUTINE wrf_inquire_opened ( DataHandle, FileName , FileStatus, Status )
    883. 

  883. !<DESCRIPTION>
    884. 

  884. !<PRE>
    885. 

  885. ! Inquire if the dataset referenced by DataHandle is open.  
    886. 

  886. !</PRE>
    887. 

  887. !</DESCRIPTION>
    888. 

  888.   USE module_state_description
    889. 

  889.   IMPLICIT NONE
    890. 

  890.   INTEGER ,       INTENT(IN)  :: DataHandle
    891. 

  891.   CHARACTER*(*) :: FileName
    892. 

  892.   INTEGER ,       INTENT(OUT) :: FileStatus
    893. 

  893.   INTEGER ,       INTENT(OUT) :: Status
    894. 

  894.   LOGICAL                     :: for_out
    895. 

  895.   INTEGER, EXTERNAL           :: use_package
    896. 

  896.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    897. 

  897. #include "wrf_io_flags.h"
    898. 

  898. #include "wrf_status_codes.h"
    899. 

  899. 

  900.   INTEGER io_form , Hndl
    901. 

  901. 

  902.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_inquire_opened' )
    903. 

  903. 

  904.   Status = 0
    905. 

  905.   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
    906. 

  906.   IF ( Hndl .GT. -1 ) THEN
    907. 

  907.     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
    908. 

  908.       SELECT CASE ( use_package(io_form) )
    909. 

  909. #ifdef NETCDF
    910. 

  910.         CASE ( IO_NETCDF   )
    911. 

  911.           IF (wrf_dm_on_monitor()) CALL ext_ncd_inquire_opened ( Hndl, FileName , FileStatus, Status )
    912. 

  912.           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
    913. 

  913.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    914. 

  914. #endif
    915. 

  915. #ifdef PHDF5
    916. 

  916.       CASE ( IO_PHDF5   )
    917. 

  917.           CALL ext_phdf5_inquire_opened ( Hndl, FileName , FileStatus, Status )
    918. 

  918. #endif
    919. 

  919. #ifdef PNETCDF
    920. 

  920.       CASE ( IO_PNETCDF   )
    921. 

  921.           CALL ext_pnc_inquire_opened ( Hndl, FileName , FileStatus, Status )
    922. 

  922. #endif
    923. 

  923. #ifdef XXX
    924. 

  924.       CASE ( IO_XXX   )
    925. 

  925.           CALL ext_xxx_inquire_opened ( Hndl, FileName , FileStatus, Status )
    926. 

  926. #endif
    927. 

  927. #ifdef YYY
    928. 

  928.       CASE ( IO_YYY   )
    929. 

  929.           IF (wrf_dm_on_monitor()) CALL ext_yyy_inquire_opened ( Hndl, FileName , FileStatus, Status )
    930. 

  930.           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
    931. 

  931.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    932. 

  932. #endif
    933. 

  933. #ifdef ZZZ
    934. 

  934.       CASE ( IO_ZZZ   )
    935. 

  935.           CALL ext_zzz_inquire_opened ( Hndl, FileName , FileStatus, Status )
    936. 

  936. #endif
    937. 

  937. #ifdef GRIB1
    938. 

  938.       CASE ( IO_GRIB1   )
    939. 

  939.           IF (wrf_dm_on_monitor()) CALL ext_gr1_inquire_opened ( Hndl, FileName , FileStatus, Status )
    940. 

  940.           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
    941. 

  941.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    942. 

  942. #endif
    943. 

  943. #ifdef GRIB2
    944. 

  944.       CASE ( IO_GRIB2   )
    945. 

  945.           IF (wrf_dm_on_monitor()) CALL ext_gr2_inquire_opened ( Hndl, FileName , FileStatus, Status )
    946. 

  946.           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
    947. 

  947.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    948. 

  948. #endif
    949. 

  949. #ifdef INTIO
    950. 

  950.       CASE ( IO_INTIO   )
    951. 

  951.           IF (wrf_dm_on_monitor()) CALL ext_int_inquire_opened ( Hndl, FileName , FileStatus, Status )
    952. 

  952.           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
    953. 

  953.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    954. 

  954. #endif
    955. 

  955.         CASE DEFAULT
    956. 

  956.           FileStatus = WRF_FILE_NOT_OPENED
    957. 

  957.           Status = 0
    958. 

  958.       END SELECT
    959. 

  959.     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
    960. 

  960.       CALL wrf_quilt_inquire_opened ( Hndl, FileName , FileStatus, Status )
    961. 

  961.     ENDIF
    962. 

  962.   ELSE
    963. 

  963.     FileStatus = WRF_FILE_NOT_OPENED
    964. 

  964.     Status = 0
    965. 

  965.   ENDIF
    966. 

  966.   RETURN
    967. 

  967. END SUBROUTINE wrf_inquire_opened
    968. 

  968. 

  969. !--- inquire_filename
    970. 

  970. 

  971. 

  972. SUBROUTINE wrf_inquire_filename ( DataHandle, FileName , FileStatus, Status )
    973. 

  973. !<DESCRIPTION>
    974. 

  974. !<PRE>
    975. 

  975. ! Returns the Filename and FileStatus associated with DataHandle.  
    976. 

  976. !</PRE>
    977. 

  977. !</DESCRIPTION>
    978. 

  978.   USE module_state_description
    979. 

  979.   IMPLICIT NONE
    980. 

  980.   INTEGER ,       INTENT(IN)  :: DataHandle
    981. 

  981.   CHARACTER*(*) :: FileName
    982. 

  982.   INTEGER ,       INTENT(OUT) :: FileStatus
    983. 

  983.   INTEGER ,       INTENT(OUT) :: Status
    984. 

  984. #include "wrf_status_codes.h"
    985. 

  985.   INTEGER, EXTERNAL           :: use_package
    986. 

  986.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    987. 

  987.   LOGICAL                     :: for_out
    988. 

  988. 

  989.   INTEGER io_form , Hndl
    990. 

  990.   INTEGER                     :: str_length , str_count
    991. 

  991. 

  992.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_inquire_filename' )
    993. 

  993. 

  994.   Status = 0
    995. 

  995.   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
    996. 

  996.   IF ( Hndl .GT. -1 ) THEN
    997. 

  997.     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
    998. 

  998.       SELECT CASE ( use_package( io_form ) )
    999. 

  999. #ifdef NETCDF
    1000. 

  1000.         CASE ( IO_NETCDF   )
    1001. 

  1001.           str_length = LEN ( FileName )
    1002. 

  1002.           DO str_count = 1 , str_length
    1003. 

  1003.             FileName(str_count:str_count) = ' '
    1004. 

  1004.           END DO
    1005. 

  1005.           IF (wrf_dm_on_monitor()) CALL ext_ncd_inquire_filename ( Hndl, FileName , FileStatus, Status )
    1006. 

  1006.           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
    1007. 

  1007.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    1008. 

  1008. #endif
    1009. 

  1009. #ifdef PHDF5
    1010. 

  1010.         CASE ( IO_PHDF5   )
    1011. 

  1011.           CALL ext_phdf5_inquire_filename ( Hndl, FileName , FileStatus, Status )
    1012. 

  1012. #endif
    1013. 

  1013. #ifdef PNETCDF
    1014. 

  1014.         CASE ( IO_PNETCDF   )
    1015. 

  1015.           CALL ext_pnc_inquire_filename ( Hndl, FileName , FileStatus, Status )
    1016. 

  1016. #endif
    1017. 

  1017. #ifdef XXX
    1018. 

  1018.         CASE ( IO_XXX   )
    1019. 

  1019.           CALL ext_xxx_inquire_filename ( Hndl, FileName , FileStatus, Status )
    1020. 

  1020. #endif
    1021. 

  1021. #ifdef YYY
    1022. 

  1022.         CASE ( IO_YYY   )
    1023. 

  1023.           IF (wrf_dm_on_monitor()) CALL ext_yyy_inquire_filename ( Hndl, FileName , FileStatus, Status )
    1024. 

  1024.           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
    1025. 

  1025.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    1026. 

  1026. #endif
    1027. 

  1027. #ifdef ZZZ
    1028. 

  1028.         CASE ( IO_ZZZ   )
    1029. 

  1029.             CALL ext_zzz_inquire_filename ( Hndl, FileName , FileStatus, Status )
    1030. 

  1030. #endif
    1031. 

  1031. #ifdef GRIB1
    1032. 

  1032.         CASE ( IO_GRIB1   )
    1033. 

  1033.           IF (wrf_dm_on_monitor()) CALL ext_gr1_inquire_filename ( Hndl, FileName , FileStatus, Status )
    1034. 

  1034.           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
    1035. 

  1035.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    1036. 

  1036. #endif
    1037. 

  1037. #ifdef GRIB2
    1038. 

  1038.         CASE ( IO_GRIB2   )
    1039. 

  1039.           IF (wrf_dm_on_monitor()) CALL ext_gr2_inquire_filename ( Hndl, FileName , FileStatus, Status )
    1040. 

  1040.           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
    1041. 

  1041.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    1042. 

  1042. #endif
    1043. 

  1043. #ifdef INTIO
    1044. 

  1044.         CASE ( IO_INTIO   )
    1045. 

  1045.           IF (wrf_dm_on_monitor()) CALL ext_int_inquire_filename ( Hndl, FileName , FileStatus, Status )
    1046. 

  1046.           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
    1047. 

  1047.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    1048. 

  1048. #endif
    1049. 

  1049.         CASE DEFAULT
    1050. 

  1050.           Status = 0
    1051. 

  1051.       END SELECT
    1052. 

  1052.     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
    1053. 

  1053.       CALL wrf_quilt_inquire_filename ( Hndl, FileName , FileStatus, Status )
    1054. 

  1054.     ENDIF
    1055. 

  1055.   ELSE
    1056. 

  1056.     FileName = ""
    1057. 

  1057.     Status = 0
    1058. 

  1058.   ENDIF
    1059. 

  1059.   RETURN
    1060. 

  1060. END SUBROUTINE wrf_inquire_filename
    1061. 

  1061. 

  1062. !--- sync
    1063. 

  1063. 

  1064. SUBROUTINE wrf_iosync ( DataHandle, Status )
    1065. 

  1065. !<DESCRIPTION>
    1066. 

  1066. !<PRE>
    1067. 

  1067. ! Synchronize the disk copy of a dataset with memory buffers.  
    1068. 

  1068. !</PRE>
    1069. 

  1069. !</DESCRIPTION>
    1070. 

  1070.   USE module_state_description
    1071. 

  1071.   IMPLICIT NONE
    1072. 

  1072.   INTEGER ,       INTENT(IN)  :: DataHandle
    1073. 

  1073.   INTEGER ,       INTENT(OUT) :: Status
    1074. 

  1074. #include "wrf_status_codes.h"
    1075. 

  1075.   INTEGER, EXTERNAL           :: use_package
    1076. 

  1076.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    1077. 

  1077.   LOGICAL                     :: for_out
    1078. 

  1078. 

  1079.   INTEGER io_form , Hndl
    1080. 

  1080. 

  1081.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_iosync' )
    1082. 

  1082. 

  1083.   Status = 0
    1084. 

  1084.   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
    1085. 

  1085.   IF ( Hndl .GT. -1 ) THEN
    1086. 

  1086.     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
    1087. 

  1087.       SELECT CASE ( use_package(io_form) )
    1088. 

  1088. #ifdef NETCDF
    1089. 

  1089.         CASE ( IO_NETCDF   )
    1090. 

  1090.           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_iosync( Hndl, Status )
    1091. 

  1091.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    1092. 

  1092. #endif
    1093. 

  1093. #ifdef XXX
    1094. 

  1094.         CASE ( IO_XXX   )
    1095. 

  1095.           CALL ext_xxx_iosync( Hndl, Status )
    1096. 

  1096. #endif
    1097. 

  1097. #ifdef YYY
    1098. 

  1098.         CASE ( IO_YYY   )
    1099. 

  1099.           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_iosync( Hndl, Status )
    1100. 

  1100.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    1101. 

  1101. #endif
    1102. 

  1102. #ifdef GRIB1
    1103. 

  1103.         CASE ( IO_GRIB1   )
    1104. 

  1104.           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_iosync( Hndl, Status )
    1105. 

  1105.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    1106. 

  1106. #endif
    1107. 

  1107. #ifdef GRIB2
    1108. 

  1108.         CASE ( IO_GRIB2   )
    1109. 

  1109.           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_iosync( Hndl, Status )
    1110. 

  1110.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    1111. 

  1111. #endif
    1112. 

  1112. #ifdef ZZZ
    1113. 

  1113.         CASE ( IO_ZZZ   )
    1114. 

  1114.           CALL ext_zzz_iosync( Hndl, Status )
    1115. 

  1115. #endif
    1116. 

  1116. #ifdef INTIO
    1117. 

  1117.         CASE ( IO_INTIO   )
    1118. 

  1118.           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_int_iosync( Hndl, Status )
    1119. 

  1119.           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
    1120. 

  1120. #endif
    1121. 

  1121.         CASE DEFAULT
    1122. 

  1122.           Status = 0
    1123. 

  1123.       END SELECT
    1124. 

  1124.     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
    1125. 

  1125.       CALL wrf_quilt_iosync( Hndl, Status )
    1126. 

  1126.     ELSE
    1127. 

  1127.       Status = 0
    1128. 

  1128.     ENDIF
    1129. 

  1129.   ELSE
    1130. 

  1130.     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
    1131. 

  1131.   ENDIF
    1132. 

  1132.   RETURN
    1133. 

  1133. END SUBROUTINE wrf_iosync
    1134. 

  1134. 

  1135. !--- close
    1136. 

  1136. 

  1137. SUBROUTINE wrf_ioclose ( DataHandle, Status )
    1138. 

  1138. !<DESCRIPTION>
    1139. 

  1139. !<PRE>
    1140. 

  1140. ! Close the dataset referenced by DataHandle.  
    1141. 

  1141. !</PRE>
    1142. 

  1142. !</DESCRIPTION>
    1143. 

  1143.   USE module_state_description
    1144. 

  1144.   IMPLICIT NONE
    1145. 

  1145.   INTEGER ,       INTENT(IN)  :: DataHandle
    1146. 

  1146.   INTEGER ,       INTENT(OUT) :: Status
    1147. 

  1147. #include "wrf_status_codes.h"
    1148. 

  1148.   INTEGER, EXTERNAL           :: use_package
    1149. 

  1149.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    1150. 

  1150.   INTEGER io_form , Hndl
    1151. 

  1151.   LOGICAL                     :: for_out
    1152. 

  1152. 

  1153.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioclose' )
    1154. 

  1154. 

  1155.   Status = 0
    1156. 

  1156.   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
    1157. 

  1157.   IF ( Hndl .GT. -1 ) THEN
    1158. 

  1158.     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
    1159. 

  1159.       SELECT CASE ( use_package(io_form) )
    1160. 

  1160. #ifdef NETCDF
    1161. 

  1161.         CASE ( IO_NETCDF   )
    1162. 

  1162.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_ncd_ioclose( Hndl, Status )
    1163. 

  1163.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1164. 

  1164. #endif
    1165. 

  1165. #ifdef PHDF5
    1166. 

  1166.         CASE ( IO_PHDF5  )
    1167. 

  1167.           CALL ext_phdf5_ioclose( Hndl, Status )
    1168. 

  1168. #endif
    1169. 

  1169. #ifdef PNETCDF
    1170. 

  1170.         CASE ( IO_PNETCDF  )
    1171. 

  1171.           CALL ext_pnc_ioclose( Hndl, Status )
    1172. 

  1172. #endif
    1173. 

  1173. #ifdef XXX
    1174. 

  1174.         CASE ( IO_XXX   )
    1175. 

  1175.           CALL ext_xxx_ioclose( Hndl, Status )
    1176. 

  1176. #endif
    1177. 

  1177. #ifdef YYY
    1178. 

  1178.         CASE ( IO_YYY   )
    1179. 

  1179.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_yyy_ioclose( Hndl, Status )
    1180. 

  1180.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1181. 

  1181. #endif
    1182. 

  1182. #ifdef ZZZ
    1183. 

  1183.         CASE ( IO_ZZZ   )
    1184. 

  1184.           CALL ext_zzz_ioclose( Hndl, Status )
    1185. 

  1185. #endif
    1186. 

  1186. #ifdef GRIB1
    1187. 

  1187.         CASE ( IO_GRIB1   )
    1188. 

  1188.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr1_ioclose( Hndl, Status )
    1189. 

  1189.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1190. 

  1190. #endif
    1191. 

  1191. #ifdef GRIB2
    1192. 

  1192.         CASE ( IO_GRIB2   )
    1193. 

  1193.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr2_ioclose( Hndl, Status )
    1194. 

  1194.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1195. 

  1195. #endif
    1196. 

  1196. #ifdef MCELIO
    1197. 

  1197.         CASE ( IO_MCEL   )
    1198. 

  1198.           CALL ext_mcel_ioclose( Hndl, Status )
    1199. 

  1199. #endif
    1200. 

  1200. #ifdef ESMFIO
    1201. 

  1201.         CASE ( IO_ESMF )
    1202. 

  1202.           CALL ext_esmf_ioclose( Hndl, Status )
    1203. 

  1203. #endif
    1204. 

  1204. #ifdef INTIO
    1205. 

  1205.         CASE ( IO_INTIO   )
    1206. 

  1206.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_int_ioclose( Hndl, Status )
    1207. 

  1207.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1208. 

  1208. #endif
    1209. 

  1209.         CASE DEFAULT
    1210. 

  1210.           Status = 0
    1211. 

  1211.       END SELECT
    1212. 

  1212.     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
    1213. 

  1213.       CALL wrf_quilt_ioclose( Hndl, Status )
    1214. 

  1214.     ELSE
    1215. 

  1215.       Status = 0
    1216. 

  1216.     ENDIF
    1217. 

  1217.     CALL free_handle( DataHandle )
    1218. 

  1218.   ELSE
    1219. 

  1219.     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
    1220. 

  1220.   ENDIF
    1221. 

  1221.   RETURN
    1222. 

  1222. END SUBROUTINE wrf_ioclose
    1223. 

  1223. 

  1224. !--- get_next_time (not defined for IntIO )
    1225. 

  1225. 

  1226. SUBROUTINE wrf_get_next_time ( DataHandle, DateStr, Status )
    1227. 

  1227. !<DESCRIPTION>
    1228. 

  1228. !<PRE>
    1229. 

  1229. ! Returns the next time stamp.  
    1230. 

  1230. !</PRE>
    1231. 

  1231. !</DESCRIPTION>
    1232. 

  1232.   USE module_state_description
    1233. 

  1233.   IMPLICIT NONE
    1234. 

  1234.   INTEGER ,       INTENT(IN)  :: DataHandle
    1235. 

  1235.   CHARACTER*(*) :: DateStr
    1236. 

  1236.   INTEGER ,       INTENT(OUT) :: Status
    1237. 

  1237. #include "wrf_status_codes.h"
    1238. 

  1238. 

  1239.   INTEGER, EXTERNAL           :: use_package
    1240. 

  1240.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    1241. 

  1241.   INTEGER io_form , Hndl, len_of_str
    1242. 

  1242.   LOGICAL                     :: for_out
    1243. 

  1243. 

  1244.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_next_time' )
    1245. 

  1245. 

  1246.   Status = 0
    1247. 

  1247.   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
    1248. 

  1248.   IF ( Hndl .GT. -1 ) THEN
    1249. 

  1249.     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
    1250. 

  1250.       SELECT CASE ( use_package(io_form) )
    1251. 

  1251. #ifdef NETCDF
    1252. 

  1252.         CASE ( IO_NETCDF   )
    1253. 

  1253.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_ncd_get_next_time( Hndl, DateStr, Status )
    1254. 

  1254.           IF ( .NOT. multi_files(io_form) ) THEN
    1255. 

  1255.             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1256. 

  1256.             len_of_str = LEN(DateStr)
    1257. 

  1257.             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
    1258. 

  1258.           ENDIF
    1259. 

  1259. #endif
    1260. 

  1260. #ifdef PHDF5
    1261. 

  1261.         CASE ( IO_PHDF5   )
    1262. 

  1262.           CALL ext_phdf5_get_next_time( Hndl, DateStr, Status )
    1263. 

  1263. #endif
    1264. 

  1264. #ifdef PNETCDF
    1265. 

  1265.         CASE ( IO_PNETCDF   )
    1266. 

  1266.           CALL ext_pnc_get_next_time( Hndl, DateStr, Status )
    1267. 

  1267. #endif
    1268. 

  1268. #ifdef XXX
    1269. 

  1269.         CASE ( IO_XXX   )
    1270. 

  1270.           CALL ext_xxx_get_next_time( Hndl, DateStr, Status )
    1271. 

  1271. #endif
    1272. 

  1272. #ifdef YYY
    1273. 

  1273.         CASE ( IO_YYY   )
    1274. 

  1274.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_yyy_get_next_time( Hndl, DateStr, Status )
    1275. 

  1275.           IF ( .NOT. multi_files(io_form) ) THEN
    1276. 

  1276.             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1277. 

  1277.             len_of_str = LEN(DateStr)
    1278. 

  1278.             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
    1279. 

  1279.           ENDIF
    1280. 

  1280. #endif
    1281. 

  1281. #ifdef ZZZ
    1282. 

  1282.         CASE ( IO_ZZZ   )
    1283. 

  1283.           CALL ext_zzz_get_next_time( Hndl, DateStr, Status )
    1284. 

  1284. #endif
    1285. 

  1285. #ifdef GRIB1
    1286. 

  1286.         CASE ( IO_GRIB1   )
    1287. 

  1287.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr1_get_next_time( Hndl, DateStr, Status )
    1288. 

  1288.           IF ( .NOT. multi_files(io_form) ) THEN
    1289. 

  1289.             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1290. 

  1290.             len_of_str = LEN(DateStr)
    1291. 

  1291.             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
    1292. 

  1292.           ENDIF
    1293. 

  1293. #endif
    1294. 

  1294. #ifdef GRIB2
    1295. 

  1295.         CASE ( IO_GRIB2   )
    1296. 

  1296.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr2_get_next_time( Hndl, DateStr, Status )
    1297. 

  1297.           IF ( .NOT. multi_files(io_form) ) THEN
    1298. 

  1298.             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1299. 

  1299.             len_of_str = LEN(DateStr)
    1300. 

  1300.             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
    1301. 

  1301.           ENDIF
    1302. 

  1302. #endif
    1303. 

  1303. #ifdef INTIO
    1304. 

  1304.         CASE ( IO_INTIO   )
    1305. 

  1305.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_int_get_next_time( Hndl, DateStr, Status )
    1306. 

  1306.           IF ( .NOT. multi_files(io_form) ) THEN
    1307. 

  1307.             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1308. 

  1308.             len_of_str = LEN(DateStr)
    1309. 

  1309.             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
    1310. 

  1310.           ENDIF
    1311. 

  1311. #endif
    1312. 

  1312.         CASE DEFAULT
    1313. 

  1313.           Status = 0
    1314. 

  1314.       END SELECT
    1315. 

  1315.     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
    1316. 

  1316.       CALL wrf_quilt_get_next_time( Hndl, DateStr, Status )
    1317. 

  1317.     ELSE
    1318. 

  1318.       Status = 0
    1319. 

  1319.     ENDIF
    1320. 

  1320.   ELSE
    1321. 

  1321.     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
    1322. 

  1322.   ENDIF
    1323. 

  1323.   RETURN
    1324. 

  1324. END SUBROUTINE wrf_get_next_time
    1325. 

  1325. 

  1326. !--- get_previous_time (not defined for IntIO )
    1327. 

  1327. 

  1328. SUBROUTINE wrf_get_previous_time ( DataHandle, DateStr, Status )
    1329. 

  1329. !<DESCRIPTION>
    1330. 

  1330. !<PRE>
    1331. 

  1331. ! Returns the previous time stamp.  
    1332. 

  1332. !</PRE>
    1333. 

  1333. !</DESCRIPTION>
    1334. 

  1334.   USE module_state_description
    1335. 

  1335.   IMPLICIT NONE
    1336. 

  1336.   INTEGER ,       INTENT(IN)  :: DataHandle
    1337. 

  1337.   CHARACTER*(*) :: DateStr
    1338. 

  1338.   INTEGER ,       INTENT(OUT) :: Status
    1339. 

  1339. #include "wrf_status_codes.h"
    1340. 

  1340. 

  1341.   INTEGER, EXTERNAL           :: use_package
    1342. 

  1342.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    1343. 

  1343.   INTEGER io_form , Hndl, len_of_str
    1344. 

  1344.   LOGICAL                     :: for_out
    1345. 

  1345. 

  1346.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_previous_time' )
    1347. 

  1347. 

  1348.   Status = 0
    1349. 

  1349.   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
    1350. 

  1350.   IF ( Hndl .GT. -1 ) THEN
    1351. 

  1351.     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
    1352. 

  1352.       SELECT CASE ( use_package(io_form) )
    1353. 

  1353. #ifdef NETCDF
    1354. 

  1354.         CASE ( IO_NETCDF   )
    1355. 

  1355.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_ncd_get_previous_time( Hndl, DateStr, Status )
    1356. 

  1356.           IF ( .NOT. multi_files(io_form) ) THEN
    1357. 

  1357.             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1358. 

  1358.             len_of_str = LEN(DateStr)
    1359. 

  1359.             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
    1360. 

  1360.           ENDIF
    1361. 

  1361. #endif
    1362. 

  1362. #ifdef PHDF5
    1363. 

  1363.         CASE ( IO_PHDF5   )
    1364. 

  1364.           CALL ext_phdf5_get_previous_time( Hndl, DateStr, Status )
    1365. 

  1365. #endif
    1366. 

  1366. #ifdef PNETCDF
    1367. 

  1367.         CASE ( IO_PNETCDF   )
    1368. 

  1368.           CALL ext_pnc_get_previous_time( Hndl, DateStr, Status )
    1369. 

  1369. #endif
    1370. 

  1370. #ifdef XXX
    1371. 

  1371.         CASE ( IO_XXX   )
    1372. 

  1372.           CALL ext_xxx_get_previous_time( Hndl, DateStr, Status )
    1373. 

  1373. #endif
    1374. 

  1374. #ifdef YYY
    1375. 

  1375.         CASE ( IO_YYY   )
    1376. 

  1376.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_yyy_get_previous_time( Hndl, DateStr, Status )
    1377. 

  1377.           IF ( .NOT. multi_files(io_form) ) THEN
    1378. 

  1378.             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1379. 

  1379.             len_of_str = LEN(DateStr)
    1380. 

  1380.             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
    1381. 

  1381.          ENDIF
    1382. 

  1382. #endif
    1383. 

  1383. #ifdef ZZZ
    1384. 

  1384.         CASE ( IO_ZZZ   )
    1385. 

  1385.           CALL ext_zzz_get_previous_time( Hndl, DateStr, Status )
    1386. 

  1386. #endif
    1387. 

  1387. #ifdef GRIB1
    1388. 

  1388.         CASE ( IO_GRIB1   )
    1389. 

  1389.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr1_get_previous_time( Hndl, DateStr, Status )
    1390. 

  1390.           IF ( .NOT. multi_files(io_form) ) THEN
    1391. 

  1391.             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1392. 

  1392.             len_of_str = LEN(DateStr)
    1393. 

  1393.             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
    1394. 

  1394.          ENDIF
    1395. 

  1395. #endif
    1396. 

  1396. #ifdef GRIB2
    1397. 

  1397.         CASE ( IO_GRIB2   )
    1398. 

  1398.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr2_get_previous_time( Hndl, DateStr, Status )
    1399. 

  1399.           IF ( .NOT. multi_files(io_form) ) THEN
    1400. 

  1400.             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1401. 

  1401.             len_of_str = LEN(DateStr)
    1402. 

  1402.             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
    1403. 

  1403.          ENDIF
    1404. 

  1404. #endif
    1405. 

  1405. #ifdef INTIO
    1406. 

  1406. #endif
    1407. 

  1407.         CASE DEFAULT
    1408. 

  1408.           Status = 0
    1409. 

  1409.       END SELECT
    1410. 

  1410.     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
    1411. 

  1411.       CALL wrf_quilt_get_previous_time( Hndl, DateStr, Status )
    1412. 

  1412.     ELSE
    1413. 

  1413.       Status = 0
    1414. 

  1414.     ENDIF
    1415. 

  1415.   ELSE
    1416. 

  1416.     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
    1417. 

  1417.   ENDIF
    1418. 

  1418.   RETURN
    1419. 

  1419. END SUBROUTINE wrf_get_previous_time
    1420. 

  1420. 

  1421. !--- set_time
    1422. 

  1422. 

  1423. SUBROUTINE wrf_set_time ( DataHandle, DateStr, Status )
    1424. 

  1424. !<DESCRIPTION>
    1425. 

  1425. !<PRE>
    1426. 

  1426. ! Sets the time stamp.  
    1427. 

  1427. !</PRE>
    1428. 

  1428. !</DESCRIPTION>
    1429. 

  1429.   USE module_state_description
    1430. 

  1430.   IMPLICIT NONE
    1431. 

  1431.   INTEGER ,       INTENT(IN)  :: DataHandle
    1432. 

  1432.   CHARACTER*(*) :: DateStr
    1433. 

  1433.   INTEGER ,       INTENT(OUT) :: Status
    1434. 

  1434. #include "wrf_status_codes.h"
    1435. 

  1435. 

  1436.   INTEGER, EXTERNAL           :: use_package
    1437. 

  1437.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    1438. 

  1438.   INTEGER io_form , Hndl
    1439. 

  1439.   LOGICAL                     :: for_out
    1440. 

  1440. 

  1441.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_set_time' )
    1442. 

  1442. 

  1443.   Status = 0
    1444. 

  1444.   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
    1445. 

  1445.   IF ( Hndl .GT. -1 ) THEN
    1446. 

  1446.     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
    1447. 

  1447.       SELECT CASE ( use_package( io_form ) )
    1448. 

  1448. #ifdef NETCDF
    1449. 

  1449.         CASE ( IO_NETCDF   )
    1450. 

  1450.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_ncd_set_time( Hndl, DateStr, Status )
    1451. 

  1451.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1452. 

  1452. #endif
    1453. 

  1453. #ifdef PHDF5
    1454. 

  1454.         CASE ( IO_PHDF5  )
    1455. 

  1455.           CALL ext_phdf5_set_time( Hndl, DateStr, Status )
    1456. 

  1456. #endif
    1457. 

  1457. #ifdef PNETCDF
    1458. 

  1458.         CASE ( IO_PNETCDF  )
    1459. 

  1459.           CALL ext_pnc_set_time( Hndl, DateStr, Status )
    1460. 

  1460. #endif
    1461. 

  1461. #ifdef XXX
    1462. 

  1462.         CASE ( IO_XXX   )
    1463. 

  1463.           CALL ext_xxx_set_time( Hndl, DateStr, Status )
    1464. 

  1464. #endif
    1465. 

  1465. #ifdef YYY
    1466. 

  1466.         CASE ( IO_YYY   )
    1467. 

  1467.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_yyy_set_time( Hndl, DateStr, Status )
    1468. 

  1468.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1469. 

  1469. #endif
    1470. 

  1470. #ifdef ZZZ
    1471. 

  1471.         CASE ( IO_ZZZ   )
    1472. 

  1472.           CALL ext_zzz_set_time( Hndl, DateStr, Status )
    1473. 

  1473. #endif
    1474. 

  1474. #ifdef GRIB1
    1475. 

  1475.         CASE ( IO_GRIB1   )
    1476. 

  1476.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr1_set_time( Hndl, DateStr, Status )
    1477. 

  1477.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1478. 

  1478. #endif
    1479. 

  1479. #ifdef GRIB2
    1480. 

  1480.         CASE ( IO_GRIB2   )
    1481. 

  1481.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr2_set_time( Hndl, DateStr, Status )
    1482. 

  1482.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1483. 

  1483. #endif
    1484. 

  1484. #ifdef INTIO
    1485. 

  1485.         CASE ( IO_INTIO   )
    1486. 

  1486.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_int_set_time( Hndl, DateStr, Status )
    1487. 

  1487.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1488. 

  1488. #endif
    1489. 

  1489.         CASE DEFAULT
    1490. 

  1490.           Status = 0
    1491. 

  1491.       END SELECT
    1492. 

  1492.     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
    1493. 

  1493.       CALL wrf_quilt_set_time( Hndl, DateStr, Status )
    1494. 

  1494.     ELSE
    1495. 

  1495.       Status = 0
    1496. 

  1496.     ENDIF
    1497. 

  1497.   ELSE
    1498. 

  1498.     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
    1499. 

  1499.   ENDIF
    1500. 

  1500.   RETURN
    1501. 

  1501. END SUBROUTINE wrf_set_time
    1502. 

  1502. 

  1503. !--- get_next_var  (not defined for IntIO)
    1504. 

  1504. 

  1505. SUBROUTINE wrf_get_next_var ( DataHandle, VarName, Status )
    1506. 

  1506. !<DESCRIPTION>
    1507. 

  1507. !<PRE>
    1508. 

  1508. ! On reading, this routine returns the name of the next variable in the 
    1509. 

  1509. ! current time frame.  
    1510. 

  1510. !</PRE>
    1511. 

  1511. !</DESCRIPTION>
    1512. 

  1512.   USE module_state_description
    1513. 

  1513.   IMPLICIT NONE
    1514. 

  1514.   INTEGER ,       INTENT(IN)  :: DataHandle
    1515. 

  1515.   CHARACTER*(*) :: VarName
    1516. 

  1516.   INTEGER ,       INTENT(OUT) :: Status
    1517. 

  1517. #include "wrf_status_codes.h"
    1518. 

  1518. 

  1519.   INTEGER, EXTERNAL           :: use_package
    1520. 

  1520.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    1521. 

  1521.   INTEGER io_form , Hndl
    1522. 

  1522.   LOGICAL                     :: for_out
    1523. 

  1523. 

  1524.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_next_var' )
    1525. 

  1525. 

  1526.   Status = 0
    1527. 

  1527.   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
    1528. 

  1528.   IF ( Hndl .GT. -1 ) THEN
    1529. 

  1529.     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
    1530. 

  1530.       SELECT CASE ( use_package( io_form ) )
    1531. 

  1531. #ifdef NETCDF
    1532. 

  1532.         CASE ( IO_NETCDF   )
    1533. 

  1533.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_ncd_get_next_var( Hndl, VarName, Status )
    1534. 

  1534.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1535. 

  1535. #endif
    1536. 

  1536. #ifdef XXX
    1537. 

  1537.         CASE ( IO_XXX   )
    1538. 

  1538.           CALL ext_xxx_get_next_var( Hndl, VarName, Status )
    1539. 

  1539. #endif
    1540. 

  1540. #ifdef YYY
    1541. 

  1541.         CASE ( IO_YYY   )
    1542. 

  1542.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_yyy_get_next_var( Hndl, VarName, Status )
    1543. 

  1543.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1544. 

  1544. #endif
    1545. 

  1545. #ifdef ZZZ
    1546. 

  1546.         CASE ( IO_ZZZ   )
    1547. 

  1547.           CALL ext_zzz_get_next_var( Hndl, VarName, Status )
    1548. 

  1548. #endif
    1549. 

  1549. #ifdef GRIB1
    1550. 

  1550.         CASE ( IO_GRIB1   )
    1551. 

  1551.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr1_get_next_var( Hndl, VarName, Status )
    1552. 

  1552.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1553. 

  1553. #endif
    1554. 

  1554. #ifdef GRIB2
    1555. 

  1555.         CASE ( IO_GRIB2   )
    1556. 

  1556.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr2_get_next_var( Hndl, VarName, Status )
    1557. 

  1557.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1558. 

  1558. #endif
    1559. 

  1559. #ifdef INTIO
    1560. 

  1560.         CASE ( IO_INTIO   )
    1561. 

  1561.           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_int_get_next_var( Hndl, VarName, Status )
    1562. 

  1562.           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    1563. 

  1563. #endif
    1564. 

  1564.         CASE DEFAULT
    1565. 

  1565.           Status = 0
    1566. 

  1566.       END SELECT
    1567. 

  1567.     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
    1568. 

  1568.       CALL wrf_quilt_get_next_var( Hndl, VarName, Status )
    1569. 

  1569.     ELSE
    1570. 

  1570.       Status = 0
    1571. 

  1571.     ENDIF
    1572. 

  1572.   ELSE
    1573. 

  1573.     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
    1574. 

  1574.   ENDIF
    1575. 

  1575.   RETURN
    1576. 

  1576. END SUBROUTINE wrf_get_next_var
    1577. 

  1577. 

  1578. 

  1579. ! wrf_get_var_info  (not implemented for IntIO)
    1580. 

  1580. 

  1581. SUBROUTINE wrf_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , &
    1582. 

  1582.                               DomainStart , DomainEnd , Status )
    1583. 

  1583. !<DESCRIPTION>
    1584. 

  1584. !<PRE>
    1585. 

  1585. ! This routine applies only to a dataset that is open for read.  It returns 
    1586. 

  1586. ! information about a variable.  
    1587. 

  1587. !</PRE>
    1588. 

  1588. !</DESCRIPTION>
    1589. 

  1589.   USE module_state_description
    1590. 

  1590.   IMPLICIT NONE
    1591. 

  1591.   INTEGER               ,INTENT(IN)     :: DataHandle
    1592. 

  1592.   CHARACTER*(*)         ,INTENT(IN)     :: VarName
    1593. 

  1593.   INTEGER               ,INTENT(OUT)    :: NDim
    1594. 

  1594.   CHARACTER*(*)         ,INTENT(OUT)    :: MemoryOrder
    1595. 

  1595.   CHARACTER*(*)         ,INTENT(OUT)    :: Stagger
    1596. 

  1596.   INTEGER ,dimension(*) ,INTENT(OUT)    :: DomainStart, DomainEnd
    1597. 

  1597.   INTEGER               ,INTENT(OUT)    :: Status
    1598. 

  1598. #include "wrf_status_codes.h"
    1599. 

  1599.   INTEGER io_form , Hndl
    1600. 

  1600.   LOGICAL                     :: for_out
    1601. 

  1601.   INTEGER, EXTERNAL           :: use_package
    1602. 

  1602.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    1603. 

  1603. 

  1604.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_var_info' )
    1605. 

  1605. 

  1606.   Status = 0
    1607. 

  1607.   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
    1608. 

  1608.   IF ( Hndl .GT. -1 ) THEN
    1609. 

  1609.     IF (( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) .AND. .NOT. (for_out .AND. use_output_servers()) ) THEN
    1610. 

  1610.       SELECT CASE ( use_package( io_form ) )
    1611. 

  1611. #ifdef NETCDF
    1612. 

  1612.         CASE ( IO_NETCDF   )
    1613. 

  1613.           CALL ext_ncd_get_var_info ( Hndl , VarName , NDim ,            &
    1614. 

  1614.                                       MemoryOrder , Stagger ,                  &
    1615. 

  1615.                                       DomainStart , DomainEnd ,                &
    1616. 

  1616.                                       Status )
    1617. 

  1617. #endif
    1618. 

  1618. #ifdef PHDF5
    1619. 

  1619.         CASE ( IO_PHDF5)
    1620. 

  1620.           CALL ext_phdf5_get_var_info ( Hndl , VarName , NDim ,            &
    1621. 

  1621.                                       MemoryOrder , Stagger ,                  &
    1622. 

  1622.                                       DomainStart , DomainEnd ,                &
    1623. 

  1623.                                       Status )
    1624. 

  1624. #endif
    1625. 

  1625. #ifdef PNETCDF
    1626. 

  1626.         CASE ( IO_PNETCDF)
    1627. 

  1627.           CALL ext_pnc_get_var_info ( Hndl , VarName , NDim ,            &
    1628. 

  1628.                                       MemoryOrder , Stagger ,                  &
    1629. 

  1629.                                       DomainStart , DomainEnd ,                &
    1630. 

  1630.                                       Status )
    1631. 

  1631. #endif
    1632. 

  1632. #ifdef XXX
    1633. 

  1633.         CASE ( IO_XXX )
    1634. 

  1634.           CALL ext_xxx_get_var_info ( Hndl , VarName , NDim ,            &
    1635. 

  1635.                                       MemoryOrder , Stagger ,                  &
    1636. 

  1636.                                       DomainStart , DomainEnd ,                &
    1637. 

  1637.                                       Status )
    1638. 

  1638. #endif
    1639. 

  1639. #ifdef YYY
    1640. 

  1640.         CASE ( IO_YYY )
    1641. 

  1641.           CALL ext_yyy_get_var_info ( Hndl , VarName , NDim ,            &
    1642. 

  1642.                                       MemoryOrder , Stagger ,                  &
    1643. 

  1643.                                       DomainStart , DomainEnd ,                &
    1644. 

  1644.                                       Status )
    1645. 

  1645. #endif
    1646. 

  1646. #ifdef GRIB1
    1647. 

  1647.         CASE ( IO_GRIB1 )
    1648. 

  1648.           CALL ext_gr1_get_var_info ( Hndl , VarName , NDim ,            &
    1649. 

  1649.                                       MemoryOrder , Stagger ,                  &
    1650. 

  1650.                                       DomainStart , DomainEnd ,                &
    1651. 

  1651.                                       Status )
    1652. 

  1652. #endif
    1653. 

  1653. #ifdef GRIB2
    1654. 

  1654.         CASE ( IO_GRIB2 )
    1655. 

  1655.           CALL ext_gr2_get_var_info ( Hndl , VarName , NDim ,            &
    1656. 

  1656.                                       MemoryOrder , Stagger ,                  &
    1657. 

  1657.                                       DomainStart , DomainEnd ,                &
    1658. 

  1658.                                       Status )
    1659. 

  1659. #endif
    1660. 

  1660.         CASE DEFAULT
    1661. 

  1661.           Status = 0
    1662. 

  1662.       END SELECT
    1663. 

  1663.     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
    1664. 

  1664.       CALL wrf_quilt_get_var_info ( Hndl , VarName , NDim ,            &
    1665. 

  1665.                                     MemoryOrder , Stagger ,                  &
    1666. 

  1666.                                     DomainStart , DomainEnd ,                &
    1667. 

  1667.                                     Status )
    1668. 

  1668.     ELSE
    1669. 

  1669.       Status = 0
    1670. 

  1670.     ENDIF
    1671. 

  1671.   ELSE
    1672. 

  1672.     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
    1673. 

  1673.   ENDIF
    1674. 

  1674.   RETURN
    1675. 

  1675. 

  1676. END SUBROUTINE wrf_get_var_info
    1677. 

  1677. 

  1678. 

  1679. 

  1680. !---------------------------------------------------------------------------------
    1681. 

  1681. 

  1682. 

  1683. SUBROUTINE init_io_handles()
    1684. 

  1684. !<DESCRIPTION>
    1685. 

  1685. !<PRE>
    1686. 

  1686. ! Initialize all I/O handles.  
    1687. 

  1687. !</PRE>
    1688. 

  1688. !</DESCRIPTION>
    1689. 

  1689.   IMPLICIT NONE
    1690. 

  1690.   INTEGER i
    1691. 

  1691.   IF ( .NOT. is_inited ) THEN
    1692. 

  1692.     DO i = 1, MAX_WRF_IO_HANDLE
    1693. 

  1693.       wrf_io_handles(i) = -999319
    1694. 

  1694.     ENDDO
    1695. 

  1695.     is_inited = .TRUE.
    1696. 

  1696.   ENDIF
    1697. 

  1697.   RETURN
    1698. 

  1698. END SUBROUTINE init_io_handles
    1699. 

  1699. 

  1700. SUBROUTINE add_new_handle( Hndl, Hopened, for_out, DataHandle )
    1701. 

  1701. !<DESCRIPTION>
    1702. 

  1702. !<PRE>
    1703. 

  1703. ! Stash the package-specific I/O handle (Hndl) and return a WRF I/O handle 
    1704. 

  1704. ! (DataHandle).  
    1705. 

  1705. ! File format ID is passed in via Hopened.  
    1706. 

  1706. ! for_out will be .TRUE. if this routine was called from an 
    1707. 

  1707. ! open-for-read/write-begin operation and .FALSE. otherwise.  
    1708. 

  1708. !</PRE>
    1709. 

  1709. !</DESCRIPTION>
    1710. 

  1710.   IMPLICIT NONE
    1711. 

  1711.   INTEGER, INTENT(IN)     :: Hndl
    1712. 

  1712.   INTEGER, INTENT(IN)     :: Hopened
    1713. 

  1713.   LOGICAL, INTENT(IN)     :: for_out
    1714. 

  1714.   INTEGER, INTENT(OUT)    :: DataHandle
    1715. 

  1715.   INTEGER i
    1716. 

  1716.   INTEGER, EXTERNAL       :: use_package
    1717. 

  1717.   LOGICAL, EXTERNAL       :: multi_files
    1718. 

  1718.   IF ( .NOT. is_inited ) THEN
    1719. 

  1719.     CALL wrf_error_fatal( 'add_new_handle: not initialized' )
    1720. 

  1720.   ENDIF
    1721. 

  1721.   IF ( multi_files( Hopened ) ) THEN
    1722. 

  1722.     SELECT CASE ( use_package( Hopened ) )
    1723. 

  1723.       CASE ( IO_PHDF5  )
    1724. 

  1724.         CALL wrf_error_fatal( 'add_new_handle:  multiple output files not supported for PHDF5' )
    1725. 

  1725.       CASE ( IO_PNETCDF  )
    1726. 

  1726.         CALL wrf_error_fatal( 'add_new_handle:  multiple output files not supported for PNETCDF' )
    1727. 

  1727. #ifdef MCELIO
    1728. 

  1728.       CASE ( IO_MCEL   )
    1729. 

  1729.         CALL wrf_error_fatal( 'add_new_handle:  multiple output files not supported for MCEL' )
    1730. 

  1730. #endif
    1731. 

  1731. #ifdef ESMFIO
    1732. 

  1732.       CASE ( IO_ESMF )
    1733. 

  1733.         CALL wrf_error_fatal( 'add_new_handle:  multiple output files not supported for ESMF' )
    1734. 

  1734. #endif
    1735. 

  1735.     END SELECT
    1736. 

  1736.   ENDIF
    1737. 

  1737.   DataHandle = -1
    1738. 

  1738.   DO i = 1, MAX_WRF_IO_HANDLE
    1739. 

  1739.     IF ( wrf_io_handles(i) .EQ. -999319 ) THEN
    1740. 

  1740.       DataHandle = i 
    1741. 

  1741.       wrf_io_handles(i) = Hndl
    1742. 

  1742.       how_opened(i)     = Hopened
    1743. 

  1743.       for_output(DataHandle) = for_out
    1744. 

  1744.       first_operation(DataHandle) = .TRUE.
    1745. 

  1745.       EXIT
    1746. 

  1746.     ENDIF
    1747. 

  1747.   ENDDO
    1748. 

  1748.   IF ( DataHandle .EQ. -1 ) THEN
    1749. 

  1749.     CALL wrf_error_fatal( 'add_new_handle: no handles left' )
    1750. 

  1750.   ENDIF
    1751. 

  1751.   RETURN
    1752. 

  1752. END SUBROUTINE add_new_handle
    1753. 

  1753. 

  1754. SUBROUTINE get_handle ( Hndl, Hopened, for_out, DataHandle )
    1755. 

  1755. !<DESCRIPTION>
    1756. 

  1756. !<PRE>
    1757. 

  1757. ! Return the package-specific handle (Hndl) from a WRF handle 
    1758. 

  1758. ! (DataHandle).  
    1759. 

  1759. ! Return file format ID via Hopened.  
    1760. 

  1760. ! Also, for_out will be set to .TRUE. if the file was opened 
    1761. 

  1761. ! with an open-for-read/write-begin operation and .FALSE. 
    1762. 

  1762. ! otherwise.  
    1763. 

  1763. !</PRE>
    1764. 

  1764. !</DESCRIPTION>
    1765. 

  1765.   IMPLICIT NONE
    1766. 

  1766.   INTEGER, INTENT(OUT)     :: Hndl
    1767. 

  1767.   INTEGER, INTENT(OUT)     :: Hopened
    1768. 

  1768.   LOGICAL, INTENT(OUT)     :: for_out
    1769. 

  1769.   INTEGER, INTENT(IN)    :: DataHandle
    1770. 

  1770.   CHARACTER*128 mess
    1771. 

  1771.   INTEGER i
    1772. 

  1772.   IF ( .NOT. is_inited ) THEN
    1773. 

  1773.     CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' )
    1774. 

  1774.   ENDIF
    1775. 

  1775.   IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
    1776. 

  1776.     Hndl = wrf_io_handles(DataHandle)
    1777. 

  1777.     Hopened = how_opened(DataHandle)
    1778. 

  1778.     for_out = for_output(DataHandle)
    1779. 

  1779.   ELSE
    1780. 

  1780.     Hndl = -1
    1781. 

  1781.   ENDIF
    1782. 

  1782.   RETURN
    1783. 

  1783. END SUBROUTINE get_handle
    1784. 

  1784. 

  1785. SUBROUTINE set_first_operation( DataHandle )
    1786. 

  1786. !<DESCRIPTION>
    1787. 

  1787. !<PRE>
    1788. 

  1788. ! Sets internal flag to indicate that the first read or write has not yet 
    1789. 

  1789. ! happened for the dataset referenced by DataHandle.  
    1790. 

  1790. !</PRE>
    1791. 

  1791. !</DESCRIPTION>
    1792. 

  1792.   IMPLICIT NONE
    1793. 

  1793.   INTEGER, INTENT(IN)    :: DataHandle
    1794. 

  1794.   IF ( .NOT. is_inited ) THEN
    1795. 

  1795.     CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' )
    1796. 

  1796.   ENDIF
    1797. 

  1797.   IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
    1798. 

  1798.     first_operation(DataHandle) = .TRUE.
    1799. 

  1799.   ENDIF
    1800. 

  1800.   RETURN
    1801. 

  1801. END SUBROUTINE set_first_operation
    1802. 

  1802. 

  1803. SUBROUTINE reset_first_operation( DataHandle )
    1804. 

  1804. !<DESCRIPTION>
    1805. 

  1805. !<PRE>
    1806. 

  1806. ! Resets internal flag to indicate that the first read or write has already 
    1807. 

  1807. ! happened for the dataset referenced by DataHandle.  
    1808. 

  1808. !</PRE>
    1809. 

  1809. !</DESCRIPTION>
    1810. 

  1810.   IMPLICIT NONE
    1811. 

  1811.   INTEGER, INTENT(IN)    :: DataHandle
    1812. 

  1812.   IF ( .NOT. is_inited ) THEN
    1813. 

  1813.     CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' )
    1814. 

  1814.   ENDIF
    1815. 

  1815.   IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
    1816. 

  1816.     first_operation(DataHandle) = .FALSE.
    1817. 

  1817.   ENDIF
    1818. 

  1818.   RETURN
    1819. 

  1819. END SUBROUTINE reset_first_operation
    1820. 

  1820. 

  1821. LOGICAL FUNCTION is_first_operation( DataHandle )
    1822. 

  1822. !<DESCRIPTION>
    1823. 

  1823. !<PRE>
    1824. 

  1824. ! Returns .TRUE. the first read or write has not yet happened for the dataset 
    1825. 

  1825. ! referenced by DataHandle.  
    1826. 

  1826. !</PRE>
    1827. 

  1827. !</DESCRIPTION>
    1828. 

  1828.   IMPLICIT NONE
    1829. 

  1829.   INTEGER, INTENT(IN)    :: DataHandle
    1830. 

  1830.   IF ( .NOT. is_inited ) THEN
    1831. 

  1831.     CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' )
    1832. 

  1832.   ENDIF
    1833. 

  1833.   IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
    1834. 

  1834.     is_first_operation = first_operation(DataHandle)
    1835. 

  1835.   ENDIF
    1836. 

  1836.   RETURN
    1837. 

  1837. END FUNCTION is_first_operation
    1838. 

  1838. 

  1839. SUBROUTINE free_handle ( DataHandle )
    1840. 

  1840. !<DESCRIPTION>
    1841. 

  1841. !<PRE>
    1842. 

  1842. ! Trash a handle and return to "unused" pool.  
    1843. 

  1843. !</PRE>
    1844. 

  1844. !</DESCRIPTION>
    1845. 

  1845.   IMPLICIT NONE
    1846. 

  1846.   INTEGER, INTENT(IN)    :: DataHandle
    1847. 

  1847.   INTEGER i
    1848. 

  1848.   IF ( .NOT. is_inited ) THEN
    1849. 

  1849.     CALL wrf_error_fatal( 'free_handle: not initialized' )
    1850. 

  1850.   ENDIF
    1851. 

  1851.   IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
    1852. 

  1852.     wrf_io_handles(DataHandle) = -999319
    1853. 

  1853.   ENDIF
    1854. 

  1854.   RETURN
    1855. 

  1855. END SUBROUTINE free_handle
    1856. 

  1856. 

  1857. !--------------------------------------------------------------
    1858. 

  1858. 

  1859. SUBROUTINE init_module_io
    1860. 

  1860. !<DESCRIPTION>
    1861. 

  1861. !<PRE>
    1862. 

  1862. ! Initialize this module.  Must be called before any other operations are 
    1863. 

  1863. ! attempted.  
    1864. 

  1864. !</PRE>
    1865. 

  1865. !</DESCRIPTION>
    1866. 

  1866.   CALL init_io_handles
    1867. 

  1867. END SUBROUTINE init_module_io
    1868. 

  1868. 

  1869. SUBROUTINE are_bdys_distributed( res )
    1870. 

  1870.   IMPLICIT NONE
    1871. 

  1871.   LOGICAL, INTENT(OUT) :: res
    1872. 

  1872.   res = bdy_dist_flag
    1873. 

  1873. END SUBROUTINE are_bdys_distributed
    1874. 

  1874. 

  1875. SUBROUTINE bdys_not_distributed
    1876. 

  1876.   IMPLICIT NONE
    1877. 

  1877.   bdy_dist_flag = .FALSE.
    1878. 

  1878. END SUBROUTINE bdys_not_distributed
    1879. 

  1879. 

  1880. SUBROUTINE bdys_are_distributed
    1881. 

  1881.   IMPLICIT NONE
    1882. 

  1882.   bdy_dist_flag = .TRUE.
    1883. 

  1883. END SUBROUTINE bdys_are_distributed
    1884. 

  1884. 

  1885. LOGICAL FUNCTION on_stream ( mask , switch )
    1886. 

  1886.   IMPLICIT NONE
    1887. 

  1887.   INTEGER, INTENT(IN) :: mask(*), switch
    1888. 

  1888.   INTEGER             :: result
    1889. 

  1889. ! get_mask is a C routine defined in frame/pack_utils.c
    1890. 

  1890. ! switch is decremented from its fortran value so it is zero based
    1891. 

  1891.   CALL get_mask( mask, switch-1, result )
    1892. 

  1892.   on_stream = ( result .NE. 0 )
    1893. 

  1893. END FUNCTION on_stream
    1894. 

  1894. 

  1895. END MODULE module_io
    1896. 

  1896. 

  1897. 

  1898. !<DESCRIPTION>
    1899. 

  1899. !<PRE>
    1900. 

  1900. ! Remaining routines in this file are defined outside of the module to 
    1901. 

  1901. ! defeat arg/param type checking.  
    1902. 

  1902. !</PRE>
    1903. 

  1903. !</DESCRIPTION>
    1904. 

  1904. SUBROUTINE wrf_read_field ( DataHandle , DateStr , VarName , Field , FieldType ,         &
    1905. 

  1905.                             Comm       , IOComm  ,                                       &
    1906. 

  1906.                             DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    1907. 

  1907.                             DomainStart , DomainEnd ,                                    &
    1908. 

  1908.                             MemoryStart , MemoryEnd ,                                    &
    1909. 

  1909.                             PatchStart , PatchEnd ,                                      &
    1910. 

  1910.                             Status )
    1911. 

  1911. !<DESCRIPTION>
    1912. 

  1912. !<PRE>
    1913. 

  1913. ! Read the variable named VarName from the dataset pointed to by DataHandle.
    1914. 

  1914. ! This routine is a wrapper that ensures uniform treatment of logicals across 
    1915. 

  1915. ! platforms by reading as integer and then converting to logical.  
    1916. 

  1916. !</PRE>
    1917. 

  1917. !</DESCRIPTION>
    1918. 

  1918.   USE module_state_description
    1919. 

  1919.   USE module_configure
    1920. 

  1920.   IMPLICIT NONE
    1921. 

  1921.   INTEGER ,       INTENT(IN)    :: DataHandle
    1922. 

  1922.   CHARACTER*(*) :: DateStr
    1923. 

  1923.   CHARACTER*(*) :: VarName
    1924. 

  1924.   LOGICAL ,       INTENT(INOUT) :: Field(*)
    1925. 

  1925.   INTEGER                       ,INTENT(IN)    :: FieldType
    1926. 

  1926.   INTEGER                       ,INTENT(INOUT) :: Comm
    1927. 

  1927.   INTEGER                       ,INTENT(INOUT) :: IOComm
    1928. 

  1928.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    1929. 

  1929.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    1930. 

  1930.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    1931. 

  1931.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    1932. 

  1932.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    1933. 

  1933.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    1934. 

  1934.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    1935. 

  1935.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    1936. 

  1936.   INTEGER                       ,INTENT(OUT)   :: Status
    1937. 

  1937. #include "wrf_status_codes.h"
    1938. 

  1938. #include "wrf_io_flags.h"
    1939. 

  1939.   INTEGER, ALLOCATABLE        :: ICAST(:)
    1940. 

  1940.   LOGICAL perturb_input
    1941. 

  1941.   IF ( FieldType .EQ. WRF_LOGICAL ) THEN
    1942. 

  1942.     ALLOCATE(ICAST((MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)))
    1943. 

  1943. 

  1944.     CALL wrf_read_field1 ( DataHandle , DateStr , VarName , ICAST , WRF_INTEGER ,         &
    1945. 

  1945.                            Comm       , IOComm  ,                                       &
    1946. 

  1946.                            DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    1947. 

  1947.                            DomainStart , DomainEnd ,                                    &
    1948. 

  1948.                            MemoryStart , MemoryEnd ,                                    &
    1949. 

  1949.                            PatchStart , PatchEnd ,                                      &
    1950. 

  1950.                            Status )
    1951. 

  1951.     Field(1:(MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)) = ICAST == 1
    1952. 

  1952.     DEALLOCATE(ICAST)
    1953. 

  1953.   ELSE
    1954. 

  1954.     CALL wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType ,         &
    1955. 

  1955.                            Comm       , IOComm  ,                                       &
    1956. 

  1956.                            DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    1957. 

  1957.                            DomainStart , DomainEnd ,                                    &
    1958. 

  1958.                            MemoryStart , MemoryEnd ,                                    &
    1959. 

  1959.                            PatchStart , PatchEnd ,                                      &
    1960. 

  1960.                            Status )
    1961. 

  1961.     CALL nl_get_perturb_input( 1, perturb_input )
    1962. 

  1962.     IF ( perturb_input .AND. FieldType .EQ. WRF_FLOAT .AND. TRIM(MemoryOrder) .EQ. 'XZY' ) THEN
    1963. 

  1963.        CALL perturb_real ( Field, DomainStart, DomainEnd,        &
    1964. 

  1964.                                   MemoryStart, MemoryEnd,        &
    1965. 

  1965.                                   PatchStart, PatchEnd )
    1966. 

  1966.     ENDIF
    1967. 

  1967.   ENDIF
    1968. 

  1968. END SUBROUTINE wrf_read_field
    1969. 

  1969. 

  1970. SUBROUTINE wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType ,         &
    1971. 

  1971.                             Comm       , IOComm  ,                                       &
    1972. 

  1972.                             DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    1973. 

  1973.                             DomainStart , DomainEnd ,                                    &
    1974. 

  1974.                             MemoryStart , MemoryEnd ,                                    &
    1975. 

  1975.                             PatchStart , PatchEnd ,                                      &
    1976. 

  1976.                             Status )
    1977. 

  1977. !<DESCRIPTION>
    1978. 

  1978. !<PRE>
    1979. 

  1979. ! Read the variable named VarName from the dataset pointed to by DataHandle.
    1980. 

  1980. ! Calls ext_pkg_read_field() via call_pkg_and_dist().  
    1981. 

  1981. !</PRE>
    1982. 

  1982. !</DESCRIPTION>
    1983. 

  1983.   USE module_state_description
    1984. 

  1984.   USE module_configure
    1985. 

  1985.   USE module_io
    1986. 

  1986.   IMPLICIT NONE
    1987. 

  1987.   INTEGER ,       INTENT(IN)    :: DataHandle 
    1988. 

  1988.   CHARACTER*(*) :: DateStr
    1989. 

  1989.   CHARACTER*(*) :: VarName
    1990. 

  1990.   INTEGER ,       INTENT(INOUT) :: Field(*)
    1991. 

  1991.   INTEGER                       ,INTENT(IN)    :: FieldType
    1992. 

  1992.   INTEGER                       ,INTENT(INOUT) :: Comm 
    1993. 

  1993.   INTEGER                       ,INTENT(INOUT) :: IOComm 
    1994. 

  1994.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    1995. 

  1995.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    1996. 

  1996.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    1997. 

  1997.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    1998. 

  1998.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    1999. 

  1999.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    2000. 

  2000.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    2001. 

  2001.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    2002. 

  2002.   INTEGER                       ,INTENT(OUT)   :: Status
    2003. 

  2003. #include "wrf_status_codes.h"
    2004. 

  2004.   INTEGER io_form , Hndl
    2005. 

  2005.   LOGICAL                     :: for_out
    2006. 

  2006.   INTEGER, EXTERNAL           :: use_package
    2007. 

  2007.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers, use_input_servers
    2008. 

  2008. #ifdef NETCDF
    2009. 

  2009.   EXTERNAL     ext_ncd_read_field
    2010. 

  2010. #endif
    2011. 

  2011. #ifdef MCELIO
    2012. 

  2012.   EXTERNAL     ext_mcel_read_field
    2013. 

  2013. #endif
    2014. 

  2014. #ifdef ESMFIO
    2015. 

  2015.   EXTERNAL     ext_esmf_read_field
    2016. 

  2016. #endif
    2017. 

  2017. #ifdef INTIO
    2018. 

  2018.   EXTERNAL     ext_int_read_field
    2019. 

  2019. #endif
    2020. 

  2020. #ifdef XXX
    2021. 

  2021.   EXTERNAL ext_xxx_read_field
    2022. 

  2022. #endif
    2023. 

  2023. #ifdef YYY
    2024. 

  2024.   EXTERNAL ext_yyy_read_field
    2025. 

  2025. #endif
    2026. 

  2026. #ifdef GRIB1
    2027. 

  2027.   EXTERNAL ext_gr1_read_field
    2028. 

  2028. #endif
    2029. 

  2029. #ifdef GRIB2
    2030. 

  2030.   EXTERNAL ext_gr2_read_field
    2031. 

  2031. #endif
    2032. 

  2032. 

  2033.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_read_field' )
    2034. 

  2034. 

  2035.   Status = 0
    2036. 

  2036.   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
    2037. 

  2037.   CALL reset_first_operation( DataHandle )
    2038. 

  2038.   IF ( Hndl .GT. -1 ) THEN
    2039. 

  2039.     IF ( .NOT. io_form .GT. 0 ) THEN
    2040. 

  2040.       Status = 0 
    2041. 

  2041.     ELSE IF ( .NOT. use_input_servers() ) THEN
    2042. 

  2042.       SELECT CASE ( use_package( io_form ) )
    2043. 

  2043. #ifdef NETCDF
    2044. 

  2044.         CASE ( IO_NETCDF   )
    2045. 

  2045. 

  2046.           CALL call_pkg_and_dist   ( ext_ncd_read_field, multi_files(io_form), .false. ,        &
    2047. 

  2047.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2048. 

  2048.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2049. 

  2049.                                      DomainStart , DomainEnd ,                                    &
    2050. 

  2050.                                      MemoryStart , MemoryEnd ,                                    &
    2051. 

  2051.                                      PatchStart , PatchEnd ,                                      &
    2052. 

  2052.                                      Status )
    2053. 

  2053. 

  2054. #endif
    2055. 

  2055. #ifdef PHDF5
    2056. 

  2056.         CASE ( IO_PHDF5)
    2057. 

  2057.           CALL ext_phdf5_read_field   (                   &
    2058. 

  2058.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2059. 

  2059.                                      DomainDesc , MemoryOrder , Stagger , DimNames ,              &
    2060. 

  2060.                                      DomainStart , DomainEnd ,                                    &
    2061. 

  2061.                                      MemoryStart , MemoryEnd ,                                    &
    2062. 

  2062.                                      PatchStart , PatchEnd ,                                      &
    2063. 

  2063.                                      Status )
    2064. 

  2064. #endif
    2065. 

  2065. #ifdef PNETCDF
    2066. 

  2066.         CASE ( IO_PNETCDF)
    2067. 

  2067.           CALL ext_pnc_read_field   (                   &
    2068. 

  2068.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2069. 

  2069.                                      DomainDesc , MemoryOrder , Stagger , DimNames ,              &
    2070. 

  2070.                                      DomainStart , DomainEnd ,                                    &
    2071. 

  2071.                                      MemoryStart , MemoryEnd ,                                    &
    2072. 

  2072.                                      PatchStart , PatchEnd ,                                      &
    2073. 

  2073.                                      Status )
    2074. 

  2074. #endif
    2075. 

  2075. #ifdef MCELIO
    2076. 

  2076.         CASE ( IO_MCEL   )
    2077. 

  2077.           CALL call_pkg_and_dist   ( ext_mcel_read_field, multi_files(io_form), .true. ,         &
    2078. 

  2078.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2079. 

  2079.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2080. 

  2080.                                      DomainStart , DomainEnd ,                                    &
    2081. 

  2081.                                      MemoryStart , MemoryEnd ,                                    &
    2082. 

  2082.                                      PatchStart , PatchEnd ,                                      &
    2083. 

  2083.                                      Status )
    2084. 

  2084. #endif
    2085. 

  2085. #ifdef ESMFIO
    2086. 

  2086.         CASE ( IO_ESMF )
    2087. 

  2087.           CALL ext_esmf_read_field( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2088. 

  2088.                                     DomainDesc , MemoryOrder , Stagger , DimNames ,              &
    2089. 

  2089.                                     DomainStart , DomainEnd ,                                    &
    2090. 

  2090.                                     MemoryStart , MemoryEnd ,                                    &
    2091. 

  2091.                                     PatchStart , PatchEnd ,                                      &
    2092. 

  2092.                                     Status )
    2093. 

  2093. #endif
    2094. 

  2094. #ifdef XXX
    2095. 

  2095.         CASE ( IO_XXX )
    2096. 

  2096.           CALL call_pkg_and_dist   ( ext_xxx_read_field, multi_files(io_form), .false.,         &
    2097. 

  2097.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2098. 

  2098.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2099. 

  2099.                                      DomainStart , DomainEnd ,                                    &
    2100. 

  2100.                                      MemoryStart , MemoryEnd ,                                    &
    2101. 

  2101.                                      PatchStart , PatchEnd ,                                      &
    2102. 

  2102.                                      Status )
    2103. 

  2103. #endif
    2104. 

  2104. #ifdef YYY
    2105. 

  2105.         CASE ( IO_YYY )
    2106. 

  2106.           CALL call_pkg_and_dist   ( ext_yyy_read_field, multi_files(io_form), .false.,         &
    2107. 

  2107.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2108. 

  2108.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2109. 

  2109.                                      DomainStart , DomainEnd ,                                    &
    2110. 

  2110.                                      MemoryStart , MemoryEnd ,                                    &
    2111. 

  2111.                                      PatchStart , PatchEnd ,                                      &
    2112. 

  2112.                                      Status )
    2113. 

  2113. #endif
    2114. 

  2114. #ifdef INTIO
    2115. 

  2115.         CASE ( IO_INTIO )
    2116. 

  2116.           CALL call_pkg_and_dist   ( ext_int_read_field, multi_files(io_form), .false.,         &
    2117. 

  2117.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2118. 

  2118.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2119. 

  2119.                                      DomainStart , DomainEnd ,                                    &
    2120. 

  2120.                                      MemoryStart , MemoryEnd ,                                    &
    2121. 

  2121.                                      PatchStart , PatchEnd ,                                      &
    2122. 

  2122.                                      Status )
    2123. 

  2123. #endif
    2124. 

  2124. #ifdef GRIB1
    2125. 

  2125.         CASE ( IO_GRIB1 )
    2126. 

  2126.           CALL call_pkg_and_dist   ( ext_gr1_read_field, multi_files(io_form), .false.,         &
    2127. 

  2127.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2128. 

  2128.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2129. 

  2129.                                      DomainStart , DomainEnd ,                                    &
    2130. 

  2130.                                      MemoryStart , MemoryEnd ,                                    &
    2131. 

  2131.                                      PatchStart , PatchEnd ,                                      &
    2132. 

  2132.                                      Status )
    2133. 

  2133. #endif
    2134. 

  2134. #ifdef GRIB2
    2135. 

  2135.         CASE ( IO_GRIB2 )
    2136. 

  2136.           CALL call_pkg_and_dist   ( ext_gr2_read_field, multi_files(io_form), .false.,         &
    2137. 

  2137.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2138. 

  2138.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2139. 

  2139.                                      DomainStart , DomainEnd ,                                    &
    2140. 

  2140.                                      MemoryStart , MemoryEnd ,                                    &
    2141. 

  2141.                                      PatchStart , PatchEnd ,                                      &
    2142. 

  2142.                                      Status )
    2143. 

  2143. #endif
    2144. 

  2144.         CASE DEFAULT
    2145. 

  2145.           Status = 0
    2146. 

  2146.       END SELECT
    2147. 

  2147.     ELSE
    2148. 

  2148.       CALL wrf_error_fatal('module_io.F: wrf_read_field: input_servers not implemented yet')
    2149. 

  2149.     ENDIF
    2150. 

  2150.   ELSE
    2151. 

  2151.     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
    2152. 

  2152.   ENDIF
    2153. 

  2153.   RETURN
    2154. 

  2154. END SUBROUTINE wrf_read_field1
    2155. 

  2155. 

  2156. SUBROUTINE wrf_write_field ( DataHandle , DateStr , VarName , Field , FieldType ,         &
    2157. 

  2157.                              Comm       , IOComm  ,                                       &
    2158. 

  2158.                              DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2159. 

  2159.                              DomainStart , DomainEnd ,                                    &
    2160. 

  2160.                              MemoryStart , MemoryEnd ,                                    &
    2161. 

  2161.                              PatchStart , PatchEnd ,                                      &
    2162. 

  2162.                              Status )
    2163. 

  2163. !<DESCRIPTION>
    2164. 

  2164. !<PRE>
    2165. 

  2165. ! Write the variable named VarName to the dataset pointed to by DataHandle.
    2166. 

  2166. ! This routine is a wrapper that ensures uniform treatment of logicals across 
    2167. 

  2167. ! platforms by converting to integer before writing.  
    2168. 

  2168. !</PRE>
    2169. 

  2169. !</DESCRIPTION>
    2170. 

  2170.   USE module_state_description
    2171. 

  2171.   USE module_configure
    2172. 

  2172.   IMPLICIT NONE
    2173. 

  2173.   INTEGER ,       INTENT(IN)    :: DataHandle
    2174. 

  2174.   CHARACTER*(*) :: DateStr
    2175. 

  2175.   CHARACTER*(*) :: VarName
    2176. 

  2176.   LOGICAL ,       INTENT(IN)    :: Field(*)
    2177. 

  2177.   INTEGER                       ,INTENT(IN)    :: FieldType
    2178. 

  2178.   INTEGER                       ,INTENT(INOUT) :: Comm
    2179. 

  2179.   INTEGER                       ,INTENT(INOUT) :: IOComm
    2180. 

  2180.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    2181. 

  2181.   LOGICAL, DIMENSION(4)         ,INTENT(IN)    :: bdy_mask
    2182. 

  2182.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    2183. 

  2183.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    2184. 

  2184.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    2185. 

  2185.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    2186. 

  2186.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    2187. 

  2187.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    2188. 

  2188.   INTEGER                       ,INTENT(OUT)   :: Status
    2189. 

  2189. #include "wrf_status_codes.h"
    2190. 

  2190. #include "wrf_io_flags.h"
    2191. 

  2191.   INTEGER, ALLOCATABLE        :: ICAST(:)
    2192. 

  2192.   IF ( FieldType .EQ. WRF_LOGICAL ) THEN
    2193. 

  2193.       ALLOCATE(ICAST((MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)))
    2194. 

  2194.       ICAST = 0
    2195. 

  2195.       WHERE ( Field(1:(MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)) )
    2196. 

  2196.         ICAST = 1
    2197. 

  2197.       END WHERE
    2198. 

  2198.     CALL wrf_write_field1 ( DataHandle , DateStr , VarName , ICAST , WRF_INTEGER ,         &
    2199. 

  2199.                             Comm       , IOComm  ,                                       &
    2200. 

  2200.                             DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2201. 

  2201.                             DomainStart , DomainEnd ,                                    &
    2202. 

  2202.                             MemoryStart , MemoryEnd ,                                    &
    2203. 

  2203.                             PatchStart , PatchEnd ,                                      &
    2204. 

  2204.                             Status )
    2205. 

  2205.       DEALLOCATE(ICAST)
    2206. 

  2206.   ELSE
    2207. 

  2207.     CALL wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType ,         &
    2208. 

  2208.                             Comm       , IOComm  ,                                       &
    2209. 

  2209.                             DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2210. 

  2210.                             DomainStart , DomainEnd ,                                    &
    2211. 

  2211.                             MemoryStart , MemoryEnd ,                                    &
    2212. 

  2212.                             PatchStart , PatchEnd ,                                      &
    2213. 

  2213.                             Status )
    2214. 

  2214.   ENDIF
    2215. 

  2215. END SUBROUTINE wrf_write_field
    2216. 

  2216. 

  2217. SUBROUTINE wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType ,         &
    2218. 

  2218.                              Comm       , IOComm  ,                                       &
    2219. 

  2219.                              DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2220. 

  2220.                              DomainStart , DomainEnd ,                                    &
    2221. 

  2221.                              MemoryStart , MemoryEnd ,                                    &
    2222. 

  2222.                              PatchStart , PatchEnd ,                                      &
    2223. 

  2223.                              Status )
    2224. 

  2224. !<DESCRIPTION>
    2225. 

  2225. !<PRE>
    2226. 

  2226. ! Write the variable named VarName to the dataset pointed to by DataHandle.
    2227. 

  2227. ! Calls ext_pkg_write_field() via collect_fld_and_call_pkg().  
    2228. 

  2228. !</PRE>
    2229. 

  2229. !</DESCRIPTION>
    2230. 

  2230. 

  2231.   USE module_state_description
    2232. 

  2232.   USE module_configure
    2233. 

  2233.   USE module_io
    2234. 

  2234.   IMPLICIT NONE
    2235. 

  2235.   INTEGER ,       INTENT(IN)    :: DataHandle 
    2236. 

  2236.   CHARACTER*(*) :: DateStr
    2237. 

  2237.   CHARACTER*(*) :: VarName
    2238. 

  2238.   INTEGER ,       INTENT(IN)    :: Field(*)
    2239. 

  2239.   INTEGER                       ,INTENT(IN)    :: FieldType
    2240. 

  2240.   INTEGER                       ,INTENT(INOUT) :: Comm
    2241. 

  2241.   INTEGER                       ,INTENT(INOUT) :: IOComm
    2242. 

  2242.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    2243. 

  2243.   LOGICAL, DIMENSION(4)         ,INTENT(IN)    :: bdy_mask
    2244. 

  2244.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    2245. 

  2245.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    2246. 

  2246.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    2247. 

  2247.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    2248. 

  2248.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    2249. 

  2249.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    2250. 

  2250.   INTEGER                       ,INTENT(OUT)   :: Status
    2251. 

  2251. #include "wrf_status_codes.h"
    2252. 

  2252.   INTEGER, DIMENSION(3) :: starts, ends
    2253. 

  2253.   INTEGER io_form , Hndl
    2254. 

  2254.   CHARACTER*3 MemOrd
    2255. 

  2255.   LOGICAL                     :: for_out, okay_to_call
    2256. 

  2256.   INTEGER, EXTERNAL           :: use_package
    2257. 

  2257.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers
    2258. 

  2258. #ifdef NETCDF
    2259. 

  2259.   EXTERNAL     ext_ncd_write_field
    2260. 

  2260. #endif
    2261. 

  2261. #ifdef MCELIO
    2262. 

  2262.   EXTERNAL     ext_mcel_write_field
    2263. 

  2263. #endif
    2264. 

  2264. #ifdef ESMFIO
    2265. 

  2265.   EXTERNAL     ext_esmf_write_field
    2266. 

  2266. #endif
    2267. 

  2267. #ifdef INTIO
    2268. 

  2268.   EXTERNAL     ext_int_write_field
    2269. 

  2269. #endif
    2270. 

  2270. #ifdef XXX
    2271. 

  2271.   EXTERNAL ext_xxx_write_field
    2272. 

  2272. #endif
    2273. 

  2273. #ifdef YYY
    2274. 

  2274.   EXTERNAL ext_yyy_write_field
    2275. 

  2275. #endif
    2276. 

  2276. #ifdef GRIB1
    2277. 

  2277.   EXTERNAL ext_gr1_write_field
    2278. 

  2278. #endif
    2279. 

  2279. #ifdef GRIB2
    2280. 

  2280.   EXTERNAL ext_gr2_write_field
    2281. 

  2281. #endif
    2282. 

  2282. 

  2283.   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_write_field' )
    2284. 

  2284. 

  2285.   Status = 0
    2286. 

  2286.   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
    2287. 

  2287.   CALL reset_first_operation ( DataHandle )
    2288. 

  2288.   IF ( Hndl .GT. -1 ) THEN
    2289. 

  2289.     IF ( multi_files( io_form ) .OR. .NOT. use_output_servers() ) THEN
    2290. 

  2290.       SELECT CASE ( use_package( io_form ) )
    2291. 

  2291. #ifdef NETCDF
    2292. 

  2292.         CASE ( IO_NETCDF   )
    2293. 

  2293.           CALL collect_fld_and_call_pkg ( ext_ncd_write_field, multi_files(io_form),                  &
    2294. 

  2294.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2295. 

  2295.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2296. 

  2296.                                      DomainStart , DomainEnd ,                                    &
    2297. 

  2297.                                      MemoryStart , MemoryEnd ,                                    &
    2298. 

  2298.                                      PatchStart , PatchEnd ,                                      &
    2299. 

  2299.                                      Status )
    2300. 

  2300. #endif
    2301. 

  2301. #ifdef MCELIO
    2302. 

  2302.         CASE ( IO_MCEL   )
    2303. 

  2303.           CALL collect_fld_and_call_pkg ( ext_mcel_write_field, multi_files(io_form),                  &
    2304. 

  2304.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2305. 

  2305.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2306. 

  2306.                                      DomainStart , DomainEnd ,                                    &
    2307. 

  2307.                                      MemoryStart , MemoryEnd ,                                    &
    2308. 

  2308.                                      PatchStart , PatchEnd ,                                      &
    2309. 

  2309.                                      Status )
    2310. 

  2310. #endif
    2311. 

  2311. #ifdef ESMFIO
    2312. 

  2312.         CASE ( IO_ESMF )
    2313. 

  2313.           CALL ext_esmf_write_field( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2314. 

  2314.                                      DomainDesc , MemoryOrder , Stagger , DimNames ,              &
    2315. 

  2315.                                      DomainStart , DomainEnd ,                                    &
    2316. 

  2316.                                      MemoryStart , MemoryEnd ,                                    &
    2317. 

  2317.                                      PatchStart , PatchEnd ,                                      &
    2318. 

  2318.                                      Status )
    2319. 

  2319. #endif
    2320. 

  2320. #ifdef PHDF5
    2321. 

  2321.         CASE ( IO_PHDF5 )
    2322. 

  2322.           CALL ext_phdf5_write_field(                  &
    2323. 

  2323.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2324. 

  2324.                                      DomainDesc , MemoryOrder , Stagger , DimNames ,              &
    2325. 

  2325.                                      DomainStart , DomainEnd ,                                    &
    2326. 

  2326.                                      MemoryStart , MemoryEnd ,                                    &
    2327. 

  2327.                                      PatchStart , PatchEnd ,                                      &
    2328. 

  2328.                                      Status )
    2329. 

  2329. #endif
    2330. 

  2330. #ifdef PNETCDF
    2331. 

  2331.         CASE ( IO_PNETCDF )
    2332. 

  2332.           CALL lower_case( MemoryOrder, MemOrd )
    2333. 

  2333.           okay_to_call = .TRUE.
    2334. 

  2334.           IF ((TRIM(MemOrd).EQ.'xsz' .OR. TRIM(MemOrd).EQ.'xs').AND. .NOT. bdy_mask(P_XSB)) okay_to_call = .FALSE.
    2335. 

  2335.           IF ((TRIM(MemOrd).EQ.'xez' .OR. TRIM(MemOrd).EQ.'xe').AND. .NOT. bdy_mask(P_XEB)) okay_to_call = .FALSE.
    2336. 

  2336.           IF ((TRIM(MemOrd).EQ.'ysz' .OR. TRIM(MemOrd).EQ.'ys').AND. .NOT. bdy_mask(P_YSB)) okay_to_call = .FALSE.
    2337. 

  2337.           IF ((TRIM(MemOrd).EQ.'yez' .OR. TRIM(MemOrd).EQ.'ye').AND. .NOT. bdy_mask(P_YEB)) okay_to_call = .FALSE.
    2338. 

  2338.           IF ( okay_to_call ) THEN
    2339. 

  2339.              starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchEnd(1:3)
    2340. 

  2340.           ELSE
    2341. 

  2341.              starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchStart(1:3)-1
    2342. 

  2342.           ENDIF
    2343. 

  2343. 

  2344.                CALL ext_pnc_write_field(                  &
    2345. 

  2345.                                        Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2346. 

  2346.                                        DomainDesc , MemoryOrder , Stagger , DimNames ,              &
    2347. 

  2347.                                        DomainStart , DomainEnd ,                                    &
    2348. 

  2348.                                        MemoryStart , MemoryEnd ,                                    &
    2349. 

  2349.                                        starts , ends ,                                      &
    2350. 

  2350.                                        Status )
    2351. 

  2351. #endif
    2352. 

  2352. #ifdef XXX
    2353. 

  2353.         CASE ( IO_XXX )
    2354. 

  2354.           CALL collect_fld_and_call_pkg ( ext_xxx_write_field, multi_files(io_form),                  &
    2355. 

  2355.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2356. 

  2356.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2357. 

  2357.                                      DomainStart , DomainEnd ,                                    &
    2358. 

  2358.                                      MemoryStart , MemoryEnd ,                                    &
    2359. 

  2359.                                      PatchStart , PatchEnd ,                                      &
    2360. 

  2360.                                      Status )
    2361. 

  2361. #endif
    2362. 

  2362. #ifdef YYY
    2363. 

  2363.         CASE ( IO_YYY )
    2364. 

  2364.           CALL collect_fld_and_call_pkg ( ext_yyy_write_field, multi_files(io_form),                  &
    2365. 

  2365.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2366. 

  2366.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2367. 

  2367.                                      DomainStart , DomainEnd ,                                    &
    2368. 

  2368.                                      MemoryStart , MemoryEnd ,                                    &
    2369. 

  2369.                                      PatchStart , PatchEnd ,                                      &
    2370. 

  2370.                                      Status )
    2371. 

  2371. #endif
    2372. 

  2372. #ifdef GRIB1
    2373. 

  2373.         CASE ( IO_GRIB1 )
    2374. 

  2374.           CALL collect_fld_and_call_pkg ( ext_gr1_write_field, multi_files(io_form),                  &
    2375. 

  2375.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2376. 

  2376.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2377. 

  2377.                                      DomainStart , DomainEnd ,                                    &
    2378. 

  2378.                                      MemoryStart , MemoryEnd ,                                    &
    2379. 

  2379.                                      PatchStart , PatchEnd ,                                      &
    2380. 

  2380.                                      Status )
    2381. 

  2381. #endif
    2382. 

  2382. #ifdef GRIB2
    2383. 

  2383.         CASE ( IO_GRIB2 )
    2384. 

  2384.           CALL collect_fld_and_call_pkg ( ext_gr2_write_field, multi_files(io_form),                  &
    2385. 

  2385.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2386. 

  2386.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2387. 

  2387.                                      DomainStart , DomainEnd ,                                    &
    2388. 

  2388.                                      MemoryStart , MemoryEnd ,                                    &
    2389. 

  2389.                                      PatchStart , PatchEnd ,                                      &
    2390. 

  2390.                                      Status )
    2391. 

  2391. #endif
    2392. 

  2392. #ifdef INTIO
    2393. 

  2393.         CASE ( IO_INTIO )
    2394. 

  2394.           CALL collect_fld_and_call_pkg ( ext_int_write_field, multi_files(io_form),                  &
    2395. 

  2395.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2396. 

  2396.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2397. 

  2397.                                      DomainStart , DomainEnd ,                                    &
    2398. 

  2398.                                      MemoryStart , MemoryEnd ,                                    &
    2399. 

  2399.                                      PatchStart , PatchEnd ,                                      &
    2400. 

  2400.                                      Status )
    2401. 

  2401. #endif
    2402. 

  2402.         CASE DEFAULT
    2403. 

  2403.           Status = 0
    2404. 

  2404.       END SELECT
    2405. 

  2405.     ELSE IF ( use_output_servers() ) THEN
    2406. 

  2406.       IF ( io_form .GT. 0 ) THEN
    2407. 

  2407.       CALL wrf_quilt_write_field ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2408. 

  2408.                                    DomainDesc , MemoryOrder , Stagger , DimNames ,              &
    2409. 

  2409.                                    DomainStart , DomainEnd ,                                    &
    2410. 

  2410.                                    MemoryStart , MemoryEnd ,                                    &
    2411. 

  2411.                                    PatchStart , PatchEnd ,                                      &
    2412. 

  2412.                                    Status )
    2413. 

  2413.       ENDIF
    2414. 

  2414.     ENDIF
    2415. 

  2415.   ELSE
    2416. 

  2416.     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
    2417. 

  2417.   ENDIF
    2418. 

  2418.   RETURN
    2419. 

  2419. END SUBROUTINE wrf_write_field1
    2420. 

  2420. 

  2421. SUBROUTINE get_value_from_pairs ( varname , str , retval )
    2422. 

  2422. !<DESCRIPTION>
    2423. 

  2423. !<PRE>
    2424. 

  2424. ! parse comma separated list of VARIABLE=VALUE strings and return the
    2425. 

  2425. ! value for the matching variable if such exists, otherwise return
    2426. 

  2426. ! the empty string
    2427. 

  2427. !</PRE>
    2428. 

  2428. !</DESCRIPTION>
    2429. 

  2429.   IMPLICIT NONE
    2430. 

  2430.   CHARACTER*(*) ::    varname
    2431. 

  2431.   CHARACTER*(*) ::    str
    2432. 

  2432.   CHARACTER*(*) ::    retval
    2433. 

  2433. 

  2434.   CHARACTER (128) varstr, tstr
    2435. 

  2435.   INTEGER i,j,n,varstrn
    2436. 

  2436.   LOGICAL nobreak, nobreakouter
    2437. 

  2437. 

  2438.   varstr = TRIM(varname)//"="
    2439. 

  2439.   varstrn = len(TRIM(varstr))
    2440. 

  2440.   n = len(str)
    2441. 

  2441.   retval = ""
    2442. 

  2442.   i = 1
    2443. 

  2443.   nobreakouter = .TRUE.
    2444. 

  2444.   DO WHILE ( nobreakouter )
    2445. 

  2445.     j = 1
    2446. 

  2446.     nobreak = .TRUE.
    2447. 

  2447.     tstr = ""
    2448. 

  2448. ! Potential for out of bounds array ref on str(i:i) for i > n; reported by jedwards
    2449. 

  2449. !    DO WHILE ( nobreak )
    2450. 

  2450. !      IF ( str(i:i) .NE. ',' .AND. i .LE. n ) THEN
    2451. 

  2451. !        tstr(j:j) = str(i:i)
    2452. 

  2452. !      ELSE
    2453. 

  2453. !        nobreak = .FALSE.
    2454. 

  2454. !      ENDIF
    2455. 

  2455. !      j = j + 1
    2456. 

  2456. !      i = i + 1
    2457. 

  2457. !    ENDDO
    2458. 

  2458. ! fix 20021112, JM
    2459. 

  2459.     DO WHILE ( nobreak )
    2460. 

  2460.       nobreak = .FALSE.
    2461. 

  2461.       IF ( i .LE. n ) THEN
    2462. 

  2462.         IF (str(i:i) .NE. ',' ) THEN
    2463. 

  2463.            tstr(j:j) = str(i:i)
    2464. 

  2464.            nobreak = .TRUE.
    2465. 

  2465.         ENDIF
    2466. 

  2466.       ENDIF
    2467. 

  2467.       j = j + 1
    2468. 

  2468.       i = i + 1
    2469. 

  2469.     ENDDO
    2470. 

  2470.     IF ( i .GT. n ) nobreakouter = .FALSE.
    2471. 

  2471.     IF ( varstr(1:varstrn) .EQ. tstr(1:varstrn) ) THEN
    2472. 

  2472.       retval(1:) = TRIM(tstr(varstrn+1:))
    2473. 

  2473.       nobreakouter = .FALSE.
    2474. 

  2474.     ENDIF
    2475. 

  2475.   ENDDO
    2476. 

  2476.   RETURN
    2477. 

  2477. END SUBROUTINE get_value_from_pairs
    2478. 

  2478. 

  2479. LOGICAL FUNCTION multi_files ( io_form )
    2480. 

  2480. !<DESCRIPTION>
    2481. 

  2481. !<PRE>
    2482. 

  2482. ! Returns .TRUE. iff io_form is a multi-file format.  A multi-file format 
    2483. 

  2483. ! results in one file for each compute process and can be used with any 
    2484. 

  2484. ! I/O package.  A multi-file dataset can only be read by the same number 
    2485. 

  2485. ! of tasks that were used to write it.  This feature can be useful for 
    2486. 

  2486. ! speeding up restarts on machines that support efficient parallel I/O.  
    2487. 

  2487. ! Multi-file formats cannot be used with I/O quilt servers.  
    2488. 

  2488. !</PRE>
    2489. 

  2489. !</DESCRIPTION>
    2490. 

  2490.   IMPLICIT NONE
    2491. 

  2491.   INTEGER, INTENT(IN) :: io_form
    2492. 

  2492. #ifdef DM_PARALLEL
    2493. 

  2493.   multi_files = io_form > 99
    2494. 

  2494. #else
    2495. 

  2495.   multi_files = .FALSE.
    2496. 

  2496. #endif
    2497. 

  2497. END FUNCTION multi_files
    2498. 

  2498. 

  2499. INTEGER FUNCTION use_package ( io_form )
    2500. 

  2500. !<DESCRIPTION>
    2501. 

  2501. !<PRE>
    2502. 

  2502. ! Returns the ID of the external I/O package referenced by io_form.  
    2503. 

  2503. !</PRE>
    2504. 

  2504. !</DESCRIPTION>
    2505. 

  2505.   IMPLICIT NONE
    2506. 

  2506.   INTEGER, INTENT(IN) :: io_form
    2507. 

  2507.   use_package = MOD( io_form, 100 )
    2508. 

  2508. END FUNCTION use_package
    2509. 

  2509. 

  2510. 

  2511. SUBROUTINE collect_fld_and_call_pkg (    fcn, donotcollect_arg,                                       &
    2512. 

  2512.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2513. 

  2513.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2514. 

  2514.                                      DomainStart , DomainEnd ,                                    &
    2515. 

  2515.                                      MemoryStart , MemoryEnd ,                                    &
    2516. 

  2516.                                      PatchStart , PatchEnd ,                                      &
    2517. 

  2517.                                      Status )
    2518. 

  2518. !<DESCRIPTION>
    2519. 

  2519. !<PRE>
    2520. 

  2520. ! The collect_*_and_call_pkg routines collect a distributed array onto one 
    2521. 

  2521. ! processor and then call an I/O function to write the result (or in the 
    2522. 

  2522. ! case of replicated data simply write monitor node's copy of the data)
    2523. 

  2523. ! This routine handle cases where collection can be skipped and deals with 
    2524. 

  2524. ! different data types for Field.  
    2525. 

  2525. !</PRE>
    2526. 

  2526. !</DESCRIPTION>
    2527. 

  2527.   IMPLICIT NONE
    2528. 

  2528. #include "wrf_io_flags.h"
    2529. 

  2529.   EXTERNAL fcn
    2530. 

  2530.   LOGICAL,        INTENT(IN)    :: donotcollect_arg
    2531. 

  2531.   INTEGER ,       INTENT(IN)    :: Hndl
    2532. 

  2532.   CHARACTER*(*) :: DateStr
    2533. 

  2533.   CHARACTER*(*) :: VarName
    2534. 

  2534.   INTEGER ,       INTENT(IN)    :: Field(*)
    2535. 

  2535.   INTEGER                       ,INTENT(IN)    :: FieldType
    2536. 

  2536.   INTEGER                       ,INTENT(INOUT) :: Comm
    2537. 

  2537.   INTEGER                       ,INTENT(INOUT) :: IOComm
    2538. 

  2538.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    2539. 

  2539.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    2540. 

  2540.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    2541. 

  2541.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    2542. 

  2542.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    2543. 

  2543.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    2544. 

  2544.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    2545. 

  2545.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    2546. 

  2546.   INTEGER                       ,INTENT(OUT)   :: Status
    2547. 

  2547.   LOGICAL donotcollect
    2548. 

  2548.   INTEGER ndims, nproc
    2549. 

  2549. 

  2550.   CALL dim_from_memorder( MemoryOrder , ndims)
    2551. 

  2551.   CALL wrf_get_nproc( nproc )
    2552. 

  2552.   donotcollect = donotcollect_arg .OR. (nproc .EQ. 1)
    2553. 

  2553. 

  2554.   IF ( donotcollect ) THEN
    2555. 

  2555. 

  2556.     CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2557. 

  2557.                DomainDesc , MemoryOrder , Stagger , DimNames ,                &
    2558. 

  2558.                DomainStart , DomainEnd ,                                      &
    2559. 

  2559.                MemoryStart , MemoryEnd ,                                      &
    2560. 

  2560.                PatchStart , PatchEnd ,                                        &
    2561. 

  2561.                Status )
    2562. 

  2562. 

  2563.   ELSE IF ( FieldType .EQ. WRF_DOUBLE  ) THEN
    2564. 

  2564. 

  2565.      CALL collect_double_and_call_pkg ( fcn,                                        &
    2566. 

  2566.                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2567. 

  2567.                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2568. 

  2568.                DomainStart , DomainEnd ,                                    &
    2569. 

  2569.                MemoryStart , MemoryEnd ,                                    &
    2570. 

  2570.                PatchStart , PatchEnd ,                                      &
    2571. 

  2571.                Status )
    2572. 

  2572. 

  2573.   ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
    2574. 

  2574. 

  2575.      CALL collect_real_and_call_pkg ( fcn,                                        &
    2576. 

  2576.                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2577. 

  2577.                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2578. 

  2578.                DomainStart , DomainEnd ,                                    &
    2579. 

  2579.                MemoryStart , MemoryEnd ,                                    &
    2580. 

  2580.                PatchStart , PatchEnd ,                                      &
    2581. 

  2581.                Status )
    2582. 

  2582. 

  2583.   ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
    2584. 

  2584. 

  2585.      CALL collect_int_and_call_pkg ( fcn,                                        &
    2586. 

  2586.                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2587. 

  2587.                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2588. 

  2588.                DomainStart , DomainEnd ,                                    &
    2589. 

  2589.                MemoryStart , MemoryEnd ,                                    &
    2590. 

  2590.                PatchStart , PatchEnd ,                                      &
    2591. 

  2591.                Status )
    2592. 

  2592. 

  2593.   ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
    2594. 

  2594. 

  2595.      CALL collect_logical_and_call_pkg ( fcn,                                        &
    2596. 

  2596.                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2597. 

  2597.                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    2598. 

  2598.                DomainStart , DomainEnd ,                                    &
    2599. 

  2599.                MemoryStart , MemoryEnd ,                                    &
    2600. 

  2600.                PatchStart , PatchEnd ,                                      &
    2601. 

  2601.                Status )
    2602. 

  2602. 

  2603.   ENDIF
    2604. 

  2604.   RETURN
    2605. 

  2605. END SUBROUTINE collect_fld_and_call_pkg
    2606. 

  2606. 

  2607. SUBROUTINE collect_real_and_call_pkg (   fcn,                                                     &
    2608. 

  2608.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2609. 

  2609.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
    2610. 

  2610.                                      DomainStart , DomainEnd ,                                    &
    2611. 

  2611.                                      MemoryStart , MemoryEnd ,                                    &
    2612. 

  2612.                                      PatchStart , PatchEnd ,                                      &
    2613. 

  2613.                                      Status )
    2614. 

  2614. !<DESCRIPTION>
    2615. 

  2615. !<PRE>
    2616. 

  2616. ! The collect_*_and_call_pkg routines collect a distributed array onto one 
    2617. 

  2617. ! processor and then call an I/O function to write the result (or in the 
    2618. 

  2618. ! case of replicated data simply write monitor node's copy of the data)
    2619. 

  2619. ! The sole purpose of this wrapper is to allocate a big real buffer and 
    2620. 

  2620. ! pass it down to collect_generic_and_call_pkg() to do the actual work.  
    2621. 

  2621. !</PRE>
    2622. 

  2622. !</DESCRIPTION>
    2623. 

  2623.   USE module_state_description
    2624. 

  2624.   USE module_driver_constants
    2625. 

  2625.   IMPLICIT NONE
    2626. 

  2626.   EXTERNAL fcn
    2627. 

  2627.   INTEGER ,       INTENT(IN)    :: Hndl
    2628. 

  2628.   CHARACTER*(*) :: DateStr
    2629. 

  2629.   CHARACTER*(*) :: VarName
    2630. 

  2630.   REAL    ,       INTENT(IN)    :: Field(*)
    2631. 

  2631.   INTEGER                       ,INTENT(IN)    :: FieldType
    2632. 

  2632.   INTEGER                       ,INTENT(INOUT) :: Comm
    2633. 

  2633.   INTEGER                       ,INTENT(INOUT) :: IOComm
    2634. 

  2634.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    2635. 

  2635.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    2636. 

  2636.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    2637. 

  2637.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    2638. 

  2638.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    2639. 

  2639.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    2640. 

  2640.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    2641. 

  2641.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    2642. 

  2642.   INTEGER                       ,INTENT(INOUT)   :: Status
    2643. 

  2643.   REAL, ALLOCATABLE :: globbuf (:)
    2644. 

  2644.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor
    2645. 

  2645. 

  2646.   IF ( wrf_dm_on_monitor() ) THEN
    2647. 

  2647.     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
    2648. 

  2648.   ELSE
    2649. 

  2649.     ALLOCATE( globbuf( 1 ) )
    2650. 

  2650.   ENDIF
    2651. 

  2651. 

  2652. #ifdef DEREF_KLUDGE
    2653. 

  2653. # define FRSTELEM (1)
    2654. 

  2654. #else
    2655. 

  2655. # define FRSTELEM
    2656. 

  2656. #endif
    2657. 

  2657.   
    2658. 

  2658.   CALL collect_generic_and_call_pkg (   fcn, globbuf FRSTELEM,                                    &
    2659. 

  2659.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2660. 

  2660.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
    2661. 

  2661.                                      DomainStart , DomainEnd ,                                    &
    2662. 

  2662.                                      MemoryStart , MemoryEnd ,                                    &
    2663. 

  2663.                                      PatchStart , PatchEnd ,                                      &
    2664. 

  2664.                                      Status )
    2665. 

  2665.   DEALLOCATE ( globbuf )
    2666. 

  2666.   RETURN
    2667. 

  2667. 

  2668. END SUBROUTINE collect_real_and_call_pkg
    2669. 

  2669. 

  2670. SUBROUTINE collect_int_and_call_pkg (   fcn,                                                     &
    2671. 

  2671.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2672. 

  2672.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
    2673. 

  2673.                                      DomainStart , DomainEnd ,                                    &
    2674. 

  2674.                                      MemoryStart , MemoryEnd ,                                    &
    2675. 

  2675.                                      PatchStart , PatchEnd ,                                      &
    2676. 

  2676.                                      Status )
    2677. 

  2677. !<DESCRIPTION>
    2678. 

  2678. !<PRE>
    2679. 

  2679. ! The collect_*_and_call_pkg routines collect a distributed array onto one 
    2680. 

  2680. ! processor and then call an I/O function to write the result (or in the 
    2681. 

  2681. ! case of replicated data simply write monitor node's copy of the data)
    2682. 

  2682. ! The sole purpose of this wrapper is to allocate a big integer buffer and 
    2683. 

  2683. ! pass it down to collect_generic_and_call_pkg() to do the actual work.  
    2684. 

  2684. !</PRE>
    2685. 

  2685. !</DESCRIPTION>
    2686. 

  2686.   USE module_state_description
    2687. 

  2687.   USE module_driver_constants
    2688. 

  2688.   IMPLICIT NONE
    2689. 

  2689.   EXTERNAL fcn
    2690. 

  2690.   INTEGER ,       INTENT(IN)    :: Hndl
    2691. 

  2691.   CHARACTER*(*) :: DateStr
    2692. 

  2692.   CHARACTER*(*) :: VarName
    2693. 

  2693.   INTEGER    ,       INTENT(IN)    :: Field(*)
    2694. 

  2694.   INTEGER                       ,INTENT(IN)    :: FieldType
    2695. 

  2695.   INTEGER                       ,INTENT(INOUT) :: Comm
    2696. 

  2696.   INTEGER                       ,INTENT(INOUT) :: IOComm
    2697. 

  2697.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    2698. 

  2698.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    2699. 

  2699.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    2700. 

  2700.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    2701. 

  2701.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    2702. 

  2702.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    2703. 

  2703.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    2704. 

  2704.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    2705. 

  2705.   INTEGER                       ,INTENT(INOUT)   :: Status
    2706. 

  2706.   INTEGER, ALLOCATABLE :: globbuf (:)
    2707. 

  2707.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor
    2708. 

  2708. 

  2709.   IF ( wrf_dm_on_monitor() ) THEN
    2710. 

  2710.     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
    2711. 

  2711.   ELSE
    2712. 

  2712.     ALLOCATE( globbuf( 1 ) )
    2713. 

  2713.   ENDIF
    2714. 

  2714. 

  2715.   CALL collect_generic_and_call_pkg (   fcn, globbuf FRSTELEM ,                                   &
    2716. 

  2716.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2717. 

  2717.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
    2718. 

  2718.                                      DomainStart , DomainEnd ,                                    &
    2719. 

  2719.                                      MemoryStart , MemoryEnd ,                                    &
    2720. 

  2720.                                      PatchStart , PatchEnd ,                                      &
    2721. 

  2721.                                      Status )
    2722. 

  2722.   DEALLOCATE ( globbuf )
    2723. 

  2723.   RETURN
    2724. 

  2724. 

  2725. END SUBROUTINE collect_int_and_call_pkg
    2726. 

  2726. 

  2727. SUBROUTINE collect_double_and_call_pkg (   fcn,                                                     &
    2728. 

  2728.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2729. 

  2729.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
    2730. 

  2730.                                      DomainStart , DomainEnd ,                                    &
    2731. 

  2731.                                      MemoryStart , MemoryEnd ,                                    &
    2732. 

  2732.                                      PatchStart , PatchEnd ,                                      &
    2733. 

  2733.                                      Status )
    2734. 

  2734. !<DESCRIPTION>
    2735. 

  2735. !<PRE>
    2736. 

  2736. ! The collect_*_and_call_pkg routines collect a distributed array onto one 
    2737. 

  2737. ! processor and then call an I/O function to write the result (or in the 
    2738. 

  2738. ! case of replicated data simply write monitor node's copy of the data)
    2739. 

  2739. ! The sole purpose of this wrapper is to allocate a big double precision 
    2740. 

  2740. ! buffer and pass it down to collect_generic_and_call_pkg() to do the 
    2741. 

  2741. ! actual work.  
    2742. 

  2742. !</PRE>
    2743. 

  2743. !</DESCRIPTION>
    2744. 

  2744.   USE module_state_description
    2745. 

  2745.   USE module_driver_constants
    2746. 

  2746.   IMPLICIT NONE
    2747. 

  2747.   EXTERNAL fcn
    2748. 

  2748.   INTEGER ,       INTENT(IN)    :: Hndl
    2749. 

  2749.   CHARACTER*(*) :: DateStr
    2750. 

  2750.   CHARACTER*(*) :: VarName
    2751. 

  2751.   DOUBLE PRECISION    ,       INTENT(IN)    :: Field(*)
    2752. 

  2752.   INTEGER                       ,INTENT(IN)    :: FieldType
    2753. 

  2753.   INTEGER                       ,INTENT(INOUT) :: Comm
    2754. 

  2754.   INTEGER                       ,INTENT(INOUT) :: IOComm
    2755. 

  2755.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    2756. 

  2756.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    2757. 

  2757.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    2758. 

  2758.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    2759. 

  2759.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    2760. 

  2760.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    2761. 

  2761.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    2762. 

  2762.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    2763. 

  2763.   INTEGER                       ,INTENT(INOUT)   :: Status
    2764. 

  2764.   DOUBLE PRECISION, ALLOCATABLE :: globbuf (:)
    2765. 

  2765.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor
    2766. 

  2766. 

  2767.   IF ( wrf_dm_on_monitor() ) THEN
    2768. 

  2768.     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
    2769. 

  2769.   ELSE
    2770. 

  2770.     ALLOCATE( globbuf( 1 ) )
    2771. 

  2771.   ENDIF
    2772. 

  2772. 

  2773.   CALL collect_generic_and_call_pkg (   fcn, globbuf FRSTELEM ,                                   &
    2774. 

  2774.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2775. 

  2775.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
    2776. 

  2776.                                      DomainStart , DomainEnd ,                                    &
    2777. 

  2777.                                      MemoryStart , MemoryEnd ,                                    &
    2778. 

  2778.                                      PatchStart , PatchEnd ,                                      &
    2779. 

  2779.                                      Status )
    2780. 

  2780.   DEALLOCATE ( globbuf )
    2781. 

  2781.   RETURN
    2782. 

  2782. 

  2783. END SUBROUTINE collect_double_and_call_pkg
    2784. 

  2784. 

  2785. SUBROUTINE collect_logical_and_call_pkg (   fcn,                                                     &
    2786. 

  2786.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2787. 

  2787.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
    2788. 

  2788.                                      DomainStart , DomainEnd ,                                    &
    2789. 

  2789.                                      MemoryStart , MemoryEnd ,                                    &
    2790. 

  2790.                                      PatchStart , PatchEnd ,                                      &
    2791. 

  2791.                                      Status )
    2792. 

  2792. !<DESCRIPTION>
    2793. 

  2793. !<PRE>
    2794. 

  2794. ! The collect_*_and_call_pkg routines collect a distributed array onto one 
    2795. 

  2795. ! processor and then call an I/O function to write the result (or in the 
    2796. 

  2796. ! case of replicated data simply write monitor node's copy of the data)
    2797. 

  2797. ! The sole purpose of this wrapper is to allocate a big logical buffer 
    2798. 

  2798. ! and pass it down to collect_generic_and_call_pkg() to do the actual work.  
    2799. 

  2799. !</PRE>
    2800. 

  2800. !</DESCRIPTION>
    2801. 

  2801.   USE module_state_description
    2802. 

  2802.   USE module_driver_constants
    2803. 

  2803.   IMPLICIT NONE
    2804. 

  2804.   EXTERNAL fcn
    2805. 

  2805.   INTEGER ,       INTENT(IN)    :: Hndl
    2806. 

  2806.   CHARACTER*(*) :: DateStr
    2807. 

  2807.   CHARACTER*(*) :: VarName
    2808. 

  2808.   LOGICAL    ,       INTENT(IN)    :: Field(*)
    2809. 

  2809.   INTEGER                       ,INTENT(IN)    :: FieldType
    2810. 

  2810.   INTEGER                       ,INTENT(INOUT) :: Comm
    2811. 

  2811.   INTEGER                       ,INTENT(INOUT) :: IOComm
    2812. 

  2812.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    2813. 

  2813.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    2814. 

  2814.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    2815. 

  2815.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    2816. 

  2816.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    2817. 

  2817.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    2818. 

  2818.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    2819. 

  2819.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    2820. 

  2820.   INTEGER                       ,INTENT(INOUT)   :: Status
    2821. 

  2821.   LOGICAL, ALLOCATABLE :: globbuf (:)
    2822. 

  2822.   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor
    2823. 

  2823. 

  2824.   IF ( wrf_dm_on_monitor() ) THEN
    2825. 

  2825.     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
    2826. 

  2826.   ELSE
    2827. 

  2827.     ALLOCATE( globbuf( 1 ) )
    2828. 

  2828.   ENDIF
    2829. 

  2829. 

  2830.   CALL collect_generic_and_call_pkg (   fcn, globbuf FRSTELEM ,                                   &
    2831. 

  2831.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2832. 

  2832.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
    2833. 

  2833.                                      DomainStart , DomainEnd ,                                    &
    2834. 

  2834.                                      MemoryStart , MemoryEnd ,                                    &
    2835. 

  2835.                                      PatchStart , PatchEnd ,                                      &
    2836. 

  2836.                                      Status )
    2837. 

  2837.   DEALLOCATE ( globbuf )
    2838. 

  2838.   RETURN
    2839. 

  2839. 

  2840. END SUBROUTINE collect_logical_and_call_pkg
    2841. 

  2841. 

  2842. 

  2843. SUBROUTINE collect_generic_and_call_pkg ( fcn, globbuf,                                           &
    2844. 

  2844.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    2845. 

  2845.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
    2846. 

  2846.                                      DomainStart , DomainEnd ,                                    &
    2847. 

  2847.                                      MemoryStart , MemoryEnd ,                                    &
    2848. 

  2848.                                      PatchStart , PatchEnd ,                                      &
    2849. 

  2849.                                      Status )
    2850. 

  2850. !<DESCRIPTION>
    2851. 

  2851. !<PRE>
    2852. 

  2852. ! The collect_*_and_call_pkg routines collect a distributed array onto one 
    2853. 

  2853. ! processor and then call an I/O function to write the result (or in the 
    2854. 

  2854. ! case of replicated data simply write monitor node's copy of the data)
    2855. 

  2855. ! This routine calls the distributed memory communication routines that 
    2856. 

  2856. ! collect the array and then calls I/O function fcn to write it to disk.  
    2857. 

  2857. !</PRE>
    2858. 

  2858. !</DESCRIPTION>
    2859. 

  2859.   USE module_state_description
    2860. 

  2860.   USE module_driver_constants
    2861. 

  2861.   IMPLICIT NONE
    2862. 

  2862. #include "wrf_io_flags.h"
    2863. 

  2863. #if defined( DM_PARALLEL ) && ! defined(STUBMPI)
    2864. 

  2864. include "mpif.h"
    2865. 

  2865. #endif
    2866. 

  2866.   EXTERNAL fcn
    2867. 

  2867.   REAL , DIMENSION(*) , INTENT(INOUT) :: globbuf
    2868. 

  2868.   INTEGER ,       INTENT(IN)    :: Hndl
    2869. 

  2869.   CHARACTER*(*) :: DateStr
    2870. 

  2870.   CHARACTER*(*) :: VarName
    2871. 

  2871.   REAL    ,       INTENT(IN)    :: Field(*)
    2872. 

  2872.   INTEGER                       ,INTENT(IN)    :: FieldType
    2873. 

  2873.   INTEGER                       ,INTENT(INOUT) :: Comm
    2874. 

  2874.   INTEGER                       ,INTENT(INOUT) :: IOComm
    2875. 

  2875.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    2876. 

  2876.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    2877. 

  2877.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    2878. 

  2878.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    2879. 

  2879.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    2880. 

  2880.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    2881. 

  2881.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    2882. 

  2882.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    2883. 

  2883.   INTEGER                       ,INTENT(OUT)   :: Status
    2884. 

  2884.   CHARACTER*3 MemOrd
    2885. 

  2885.   LOGICAL, EXTERNAL :: has_char
    2886. 

  2886.   INTEGER ids, ide, jds, jde, kds, kde
    2887. 

  2887.   INTEGER ims, ime, jms, jme, kms, kme
    2888. 

  2888.   INTEGER ips, ipe, jps, jpe, kps, kpe
    2889. 

  2889.   INTEGER, ALLOCATABLE :: counts(:), displs(:)
    2890. 

  2890.   INTEGER nproc, communicator, mpi_bdyslice_type, ierr, my_displ
    2891. 

  2891.   INTEGER my_count
    2892. 

  2892.   INTEGER , dimension(3)                       :: dom_end_rev
    2893. 

  2893.   LOGICAL, EXTERNAL         :: wrf_dm_on_monitor
    2894. 

  2894.   INTEGER, EXTERNAL         :: wrf_dm_monitor_rank
    2895. 

  2895.   LOGICAL     distributed_field
    2896. 

  2896.   INTEGER i,j,k,idx,lx,idx2,lx2
    2897. 

  2897.   INTEGER collective_root
    2898. 

  2898. 

  2899.   CALL wrf_get_nproc( nproc )
    2900. 

  2900.   CALL wrf_get_dm_communicator ( communicator )
    2901. 

  2901. 

  2902.   ALLOCATE( counts( nproc ) )
    2903. 

  2903.   ALLOCATE( displs( nproc ) )
    2904. 

  2904.   CALL lower_case( MemoryOrder, MemOrd )
    2905. 

  2905. 

  2906.   collective_root = wrf_dm_monitor_rank()
    2907. 

  2907. 

  2908.   dom_end_rev(1) = DomainEnd(1)
    2909. 

  2909.   dom_end_rev(2) = DomainEnd(2)
    2910. 

  2910.   dom_end_rev(3) = DomainEnd(3)
    2911. 

  2911. 

  2912.   SELECT CASE (TRIM(MemOrd))
    2913. 

  2913.     CASE (  'xzy' )
    2914. 

  2914.       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
    2915. 

  2915.       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
    2916. 

  2916.       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
    2917. 

  2917.     CASE (  'zxy' )
    2918. 

  2918.       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
    2919. 

  2919.       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
    2920. 

  2920.       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
    2921. 

  2921.     CASE (  'xyz' )
    2922. 

  2922.       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
    2923. 

  2923.       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
    2924. 

  2924.       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
    2925. 

  2925.     CASE (  'xy' )
    2926. 

  2926.       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
    2927. 

  2927.       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
    2928. 

  2928.     CASE (  'yxz' )
    2929. 

  2929.       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
    2930. 

  2930.       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
    2931. 

  2931.       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
    2932. 

  2932.     CASE (  'yx' )
    2933. 

  2933.       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
    2934. 

  2934.       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
    2935. 

  2935.     CASE DEFAULT
    2936. 

  2936.       ! do nothing; the boundary orders and others either dont care or set themselves
    2937. 

  2937.   END SELECT
    2938. 

  2938. 

  2939.   SELECT CASE (TRIM(MemOrd))
    2940. 

  2940. #ifndef STUBMPI
    2941. 

  2941.     CASE (  'xzy','zxy','xyz','yxz','xy','yx' )
    2942. 

  2942. 

  2943.       distributed_field = .TRUE.
    2944. 

  2944.       IF ( FieldType .EQ. WRF_DOUBLE ) THEN
    2945. 

  2945.         CALL wrf_patch_to_global_double ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
    2946. 

  2946.            DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
    2947. 

  2947.            MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
    2948. 

  2948.            PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
    2949. 

  2949.       ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
    2950. 

  2950.         CALL wrf_patch_to_global_real ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
    2951. 

  2951.            DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
    2952. 

  2952.            MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
    2953. 

  2953.            PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
    2954. 

  2954.       ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
    2955. 

  2955.         CALL wrf_patch_to_global_integer ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
    2956. 

  2956.            DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
    2957. 

  2957.            MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
    2958. 

  2958.            PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
    2959. 

  2959.       ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
    2960. 

  2960.         CALL wrf_patch_to_global_logical ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
    2961. 

  2961.            DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
    2962. 

  2962.            MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
    2963. 

  2963.            PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
    2964. 

  2964.       ENDIF
    2965. 

  2965. 

  2966. #if defined(DM_PARALLEL) && !defined(STUBMPI)
    2967. 

  2967.     CASE ( 'xsz', 'xez' )
    2968. 

  2968.       distributed_field = .FALSE.
    2969. 

  2969.       IF ( nproc .GT. 1 ) THEN
    2970. 

  2970.         jds = DomainStart(1) ; jde = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) jde = jde+1  ! ns strip
    2971. 

  2971.         kds = DomainStart(2) ; kde = DomainEnd(2) ; IF ( .NOT. has_char( Stagger, 'z' ) ) kde = kde+1  ! levels
    2972. 

  2972.         ids = DomainStart(3) ; ide = DomainEnd(3) ; !  bdy_width
    2973. 

  2973.         dom_end_rev(1) = jde
    2974. 

  2974.         dom_end_rev(2) = kde
    2975. 

  2975.         dom_end_rev(3) = ide
    2976. 

  2976.         distributed_field = .TRUE.
    2977. 

  2977.         IF ( (MemOrd .eq. 'xsz' .AND. bdy_mask( P_XSB )) .OR.     &
    2978. 

  2978.              (MemOrd .eq. 'xez' .AND. bdy_mask( P_XEB ))       ) THEN
    2979. 

  2979.           my_displ = PatchStart(1)-1
    2980. 

  2980.           my_count = PatchEnd(1)-PatchStart(1)+1
    2981. 

  2981.         ELSE
    2982. 

  2982.           my_displ = 0
    2983. 

  2983.           my_count = 0
    2984. 

  2984.         ENDIF
    2985. 

  2985.         CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
    2986. 

  2986.         CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
    2987. 

  2987.         do i = DomainStart(3),DomainEnd(3)    ! bdy_width
    2988. 

  2988.         do k = DomainStart(2),DomainEnd(2)    ! levels
    2989. 

  2989.            lx   = MemoryEnd(1)-MemoryStart(1)+1
    2990. 

  2990.            lx2  = dom_end_rev(1)-DomainStart(1)+1
    2991. 

  2991.            idx  = lx*((k-1)+(i-1)*(MemoryEnd(2)-MemoryStart(2)+1))
    2992. 

  2992.            idx2 = lx2*((k-1)+(i-1)*(MemoryEnd(2)-MemoryStart(2)+1))
    2993. 

  2993.            IF ( FieldType .EQ. WRF_DOUBLE  ) THEN
    2994. 

  2994. 

  2995.              CALL wrf_gatherv_double ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
    2996. 

  2996.                              my_count ,                       &    ! sendcount
    2997. 

  2997.                              globbuf, 1+idx2 ,                &    ! recvbuf
    2998. 

  2998.                              counts                         , &    ! recvcounts
    2999. 

  2999.                              displs                         , &    ! displs
    3000. 

  3000.                              collective_root                , &    ! root
    3001. 

  3001.                              communicator                   , &    ! communicator
    3002. 

  3002.                              ierr )
    3003. 

  3003. 

  3004.            ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
    3005. 

  3005. 

  3006.              CALL wrf_gatherv_real ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
    3007. 

  3007.                              my_count ,                       &    ! sendcount
    3008. 

  3008.                              globbuf, 1+idx2 ,                &    ! recvbuf
    3009. 

  3009.                              counts                         , &    ! recvcounts
    3010. 

  3010.                              displs                         , &    ! displs
    3011. 

  3011.                              collective_root                , &    ! root
    3012. 

  3012.                              communicator                   , &    ! communicator
    3013. 

  3013.                              ierr )
    3014. 

  3014. 

  3015.            ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
    3016. 

  3016. 

  3017.              CALL wrf_gatherv_integer ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
    3018. 

  3018.                              my_count ,                       &    ! sendcount
    3019. 

  3019.                              globbuf, 1+idx2 ,                &    ! recvbuf
    3020. 

  3020.                              counts                         , &    ! recvcounts
    3021. 

  3021.                              displs                         , &    ! displs
    3022. 

  3022.                              collective_root                , &    ! root
    3023. 

  3023.                              communicator                   , &    ! communicator
    3024. 

  3024.                              ierr )
    3025. 

  3025.            ENDIF
    3026. 

  3026. 

  3027.         enddo
    3028. 

  3028.         enddo
    3029. 

  3029.       ENDIF
    3030. 

  3030.     CASE ( 'xs', 'xe' )
    3031. 

  3031.       distributed_field = .FALSE.
    3032. 

  3032.       IF ( nproc .GT. 1 ) THEN
    3033. 

  3033.         jds = DomainStart(1) ; jde = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) jde = jde+1  ! ns strip
    3034. 

  3034.         ids = DomainStart(2) ; ide = DomainEnd(2) ; !  bdy_width
    3035. 

  3035.         dom_end_rev(1) = jde
    3036. 

  3036.         dom_end_rev(2) = ide
    3037. 

  3037.         distributed_field = .TRUE.
    3038. 

  3038.         IF ( (MemOrd .eq. 'xs' .AND. bdy_mask( P_XSB )) .OR.     &
    3039. 

  3039.              (MemOrd .eq. 'xe' .AND. bdy_mask( P_XEB ))       ) THEN
    3040. 

  3040.           my_displ = PatchStart(1)-1
    3041. 

  3041.           my_count = PatchEnd(1)-PatchStart(1)+1
    3042. 

  3042.         ELSE
    3043. 

  3043.           my_displ = 0
    3044. 

  3044.           my_count = 0
    3045. 

  3045.         ENDIF
    3046. 

  3046.         CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
    3047. 

  3047.         CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
    3048. 

  3048.         do i = DomainStart(2),DomainEnd(2)    ! bdy_width
    3049. 

  3049.            lx   = MemoryEnd(1)-MemoryStart(1)+1
    3050. 

  3050.            idx  = lx*(i-1)
    3051. 

  3051.            lx2  = dom_end_rev(1)-DomainStart(1)+1
    3052. 

  3052.            idx2 = lx2*(i-1)
    3053. 

  3053.            IF ( FieldType .EQ. WRF_DOUBLE ) THEN
    3054. 

  3054. 

  3055.              CALL wrf_gatherv_double ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
    3056. 

  3056.                              my_count ,                       &    ! sendcount
    3057. 

  3057.                              globbuf, 1+idx2 ,                &    ! recvbuf
    3058. 

  3058.                              counts                         , &    ! recvcounts
    3059. 

  3059.                              displs                         , &    ! displs
    3060. 

  3060.                              collective_root                , &    ! root
    3061. 

  3061.                              communicator                   , &    ! communicator
    3062. 

  3062.                              ierr )
    3063. 

  3063. 

  3064.            ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
    3065. 

  3065. 

  3066.              CALL wrf_gatherv_real ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
    3067. 

  3067.                              my_count ,                       &    ! sendcount
    3068. 

  3068.                              globbuf, 1+idx2 ,                &    ! recvbuf
    3069. 

  3069.                              counts                         , &    ! recvcounts
    3070. 

  3070.                              displs                         , &    ! displs
    3071. 

  3071.                              collective_root                , &    ! root
    3072. 

  3072.                              communicator                   , &    ! communicator
    3073. 

  3073.                              ierr )
    3074. 

  3074. 

  3075.            ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
    3076. 

  3076. 

  3077.              CALL wrf_gatherv_integer ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
    3078. 

  3078.                              my_count ,                       &    ! sendcount
    3079. 

  3079.                              globbuf, 1+idx2 ,                &    ! recvbuf
    3080. 

  3080.                              counts                         , &    ! recvcounts
    3081. 

  3081.                              displs                         , &    ! displs
    3082. 

  3082.                              collective_root                , &    ! root
    3083. 

  3083.                              communicator                   , &    ! communicator
    3084. 

  3084.                              ierr )
    3085. 

  3085.            ENDIF
    3086. 

  3086. 

  3087.         enddo
    3088. 

  3088.       ENDIF
    3089. 

  3089.     CASE ( 'ysz', 'yez' )
    3090. 

  3090.       distributed_field = .FALSE.
    3091. 

  3091.       IF ( nproc .GT. 1 ) THEN
    3092. 

  3092.         ids = DomainStart(1) ; ide = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) ide = ide+1  ! ns strip
    3093. 

  3093.         kds = DomainStart(2) ; kde = DomainEnd(2) ; IF ( .NOT. has_char( Stagger, 'z' ) ) kde = kde+1  ! levels
    3094. 

  3094.         jds = DomainStart(3) ; jde = DomainEnd(3) ; !  bdy_width
    3095. 

  3095.         dom_end_rev(1) = ide
    3096. 

  3096.         dom_end_rev(2) = kde
    3097. 

  3097.         dom_end_rev(3) = jde
    3098. 

  3098.         distributed_field = .TRUE.
    3099. 

  3099.         IF ( (MemOrd .eq. 'ysz' .AND. bdy_mask( P_YSB )) .OR.     &
    3100. 

  3100.              (MemOrd .eq. 'yez' .AND. bdy_mask( P_YEB ))       ) THEN
    3101. 

  3101.           my_displ = PatchStart(1)-1
    3102. 

  3102.           my_count = PatchEnd(1)-PatchStart(1)+1
    3103. 

  3103.         ELSE
    3104. 

  3104.           my_displ = 0
    3105. 

  3105.           my_count = 0
    3106. 

  3106.         ENDIF
    3107. 

  3107.         CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
    3108. 

  3108.         CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
    3109. 

  3109.         do j = DomainStart(3),DomainEnd(3)    ! bdy_width
    3110. 

  3110.         do k = DomainStart(2),DomainEnd(2)    ! levels
    3111. 

  3111.            lx   = MemoryEnd(1)-MemoryStart(1)+1
    3112. 

  3112.            lx2  = dom_end_rev(1)-DomainStart(1)+1
    3113. 

  3113.            idx  = lx*((k-1)+(j-1)*(MemoryEnd(2)-MemoryStart(2)+1))
    3114. 

  3114.            idx2 = lx2*((k-1)+(j-1)*(MemoryEnd(2)-MemoryStart(2)+1))
    3115. 

  3115. 

  3116.            IF ( FieldType .EQ. WRF_DOUBLE ) THEN 
    3117. 

  3117. 

  3118.              CALL wrf_gatherv_double ( Field, PatchStart(1)-MemoryStart(1)+1+idx ,      &    ! sendbuf
    3119. 

  3119.                              my_count                       , &    ! sendcount
    3120. 

  3120.                              globbuf, 1+idx2                , &    ! recvbuf
    3121. 

  3121.                              counts                         , &    ! recvcounts
    3122. 

  3122.                              displs                         , &    ! displs
    3123. 

  3123.                              collective_root                , &    ! root
    3124. 

  3124.                              communicator                   , &    ! communicator
    3125. 

  3125.                              ierr )
    3126. 

  3126. 

  3127.            ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
    3128. 

  3128. 

  3129.              CALL wrf_gatherv_real( Field, PatchStart(1)-MemoryStart(1)+1+idx ,      &    ! sendbuf
    3130. 

  3130.                              my_count                       , &    ! sendcount
    3131. 

  3131.                              globbuf, 1+idx2                , &    ! recvbuf
    3132. 

  3132.                              counts                         , &    ! recvcounts
    3133. 

  3133.                              displs                         , &    ! displs
    3134. 

  3134.                              collective_root                , &    ! root
    3135. 

  3135.                              communicator                   , &    ! communicator
    3136. 

  3136.                              ierr )
    3137. 

  3137. 

  3138.            ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
    3139. 

  3139. 

  3140.              CALL wrf_gatherv_integer( Field, PatchStart(1)-MemoryStart(1)+1+idx ,      &    ! sendbuf
    3141. 

  3141.                              my_count                       , &    ! sendcount
    3142. 

  3142.                              globbuf, 1+idx2                , &    ! recvbuf
    3143. 

  3143.                              counts                         , &    ! recvcounts
    3144. 

  3144.                              displs                         , &    ! displs
    3145. 

  3145.                              collective_root                , &    ! root
    3146. 

  3146.                              communicator                   , &    ! communicator
    3147. 

  3147.                              ierr )
    3148. 

  3148.            ENDIF
    3149. 

  3149. 

  3150.         enddo
    3151. 

  3151.         enddo
    3152. 

  3152.       ENDIF
    3153. 

  3153.     CASE ( 'ys', 'ye' )
    3154. 

  3154.       distributed_field = .FALSE.
    3155. 

  3155.       IF ( nproc .GT. 1 ) THEN
    3156. 

  3156.         ids = DomainStart(1) ; ide = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) ide = ide+1  ! ns strip
    3157. 

  3157.         jds = DomainStart(2) ; jde = DomainEnd(2) ; !  bdy_width
    3158. 

  3158.         dom_end_rev(1) = ide
    3159. 

  3159.         dom_end_rev(2) = jde
    3160. 

  3160.         distributed_field = .TRUE.
    3161. 

  3161.         IF ( (MemOrd .eq. 'ys' .AND. bdy_mask( P_YSB )) .OR.     &
    3162. 

  3162.              (MemOrd .eq. 'ye' .AND. bdy_mask( P_YEB ))       ) THEN
    3163. 

  3163.           my_displ = PatchStart(1)-1
    3164. 

  3164.           my_count = PatchEnd(1)-PatchStart(1)+1
    3165. 

  3165.         ELSE
    3166. 

  3166.           my_displ = 0
    3167. 

  3167.           my_count = 0
    3168. 

  3168.         ENDIF
    3169. 

  3169.         CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
    3170. 

  3170.         CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
    3171. 

  3171.         do j = DomainStart(2),DomainEnd(2)    ! bdy_width
    3172. 

  3172.            lx   = MemoryEnd(1)-MemoryStart(1)+1
    3173. 

  3173.            idx  = lx*(j-1)
    3174. 

  3174.            lx2  = dom_end_rev(1)-DomainStart(1)+1
    3175. 

  3175.            idx2 = lx2*(j-1)
    3176. 

  3176. 

  3177.            IF ( FieldType .EQ. WRF_DOUBLE ) THEN 
    3178. 

  3178. 

  3179.              CALL wrf_gatherv_double( Field, PatchStart(1)-MemoryStart(1)+1+idx ,      &    ! sendbuf
    3180. 

  3180.                              my_count                       , &    ! sendcount
    3181. 

  3181.                              globbuf, 1+idx2                , &    ! recvbuf
    3182. 

  3182.                              counts                         , &    ! recvcounts
    3183. 

  3183.                              displs                         , &    ! displs
    3184. 

  3184.                              collective_root                , &    ! root
    3185. 

  3185.                              communicator                   , &    ! communicator
    3186. 

  3186.                              ierr )
    3187. 

  3187. 

  3188.            ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
    3189. 

  3189. 

  3190.              CALL wrf_gatherv_real( Field, PatchStart(1)-MemoryStart(1)+1+idx ,      &    ! sendbuf
    3191. 

  3191.                              my_count                       , &    ! sendcount
    3192. 

  3192.                              globbuf, 1+idx2                , &    ! recvbuf
    3193. 

  3193.                              counts                         , &    ! recvcounts
    3194. 

  3194.                              displs                         , &    ! displs
    3195. 

  3195.                              collective_root                , &    ! root
    3196. 

  3196.                              communicator                   , &    ! communicator
    3197. 

  3197.                              ierr )
    3198. 

  3198. 

  3199.            ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
    3200. 

  3200. 

  3201.              CALL wrf_gatherv_integer( Field, PatchStart(1)-MemoryStart(1)+1+idx ,      &    ! sendbuf
    3202. 

  3202.                              my_count                       , &    ! sendcount
    3203. 

  3203.                              globbuf, 1+idx2                , &    ! recvbuf
    3204. 

  3204.                              counts                         , &    ! recvcounts
    3205. 

  3205.                              displs                         , &    ! displs
    3206. 

  3206.                              collective_root                , &    ! root
    3207. 

  3207.                              communicator                   , &    ! communicator
    3208. 

  3208.                              ierr )
    3209. 

  3209.            ENDIF
    3210. 

  3210. 

  3211.         enddo
    3212. 

  3212.       ENDIF
    3213. 

  3213. #endif
    3214. 

  3214. #endif
    3215. 

  3215.     CASE DEFAULT
    3216. 

  3216.       distributed_field = .FALSE.
    3217. 

  3217.   END SELECT
    3218. 

  3218.   IF ( wrf_dm_on_monitor() ) THEN
    3219. 

  3219.     IF ( distributed_field ) THEN
    3220. 

  3220.       CALL fcn ( Hndl , DateStr , VarName , globbuf , FieldType , Comm , IOComm , &
    3221. 

  3221.                  DomainDesc , MemoryOrder , Stagger , DimNames ,                  &
    3222. 

  3222.                  DomainStart , DomainEnd ,                                        &
    3223. 

  3223.                  DomainStart , dom_end_rev ,                                      &  ! memory dims adjust out for unstag
    3224. 

  3224.                  DomainStart , DomainEnd ,                                        &
    3225. 

  3225.                  Status )
    3226. 

  3226.     ELSE
    3227. 

  3227.       CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3228. 

  3228.                  DomainDesc , MemoryOrder , Stagger , DimNames ,                  &
    3229. 

  3229.                  DomainStart , DomainEnd ,                                        &
    3230. 

  3230.                  MemoryStart , MemoryEnd ,                                        &
    3231. 

  3231.                  PatchStart  , PatchEnd  ,                                        &
    3232. 

  3232.                  Status )
    3233. 

  3233.     ENDIF
    3234. 

  3234.   ENDIF
    3235. 

  3235.   CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
    3236. 

  3236.   DEALLOCATE( counts )
    3237. 

  3237.   DEALLOCATE( displs )
    3238. 

  3238.   RETURN
    3239. 

  3239. END SUBROUTINE collect_generic_and_call_pkg
    3240. 

  3240. 

  3241. 

  3242. SUBROUTINE call_pkg_and_dist (       fcn, donotdist_arg, update_arg,                           &
    3243. 

  3243.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3244. 

  3244.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3245. 

  3245.                                      DomainStart , DomainEnd ,                                    &
    3246. 

  3246.                                      MemoryStart , MemoryEnd ,                                    &
    3247. 

  3247.                                      PatchStart , PatchEnd ,                                      &
    3248. 

  3248.                                      Status )
    3249. 

  3249. !<DESCRIPTION>
    3250. 

  3250. !<PRE>
    3251. 

  3251. ! The call_pkg_and_dist* routines call an I/O function to read a field and then 
    3252. 

  3252. ! distribute or replicate the field across compute tasks.  
    3253. 

  3253. ! This routine handle cases where distribution/replication can be skipped and 
    3254. 

  3254. ! deals with different data types for Field.
    3255. 

  3255. !</PRE>
    3256. 

  3256. !</DESCRIPTION>
    3257. 

  3257.   IMPLICIT NONE
    3258. 

  3258. #include "wrf_io_flags.h"
    3259. 

  3259.   EXTERNAL fcn
    3260. 

  3260.   LOGICAL,        INTENT(IN)    :: donotdist_arg, update_arg  ! update means collect old field update it and dist
    3261. 

  3261.   INTEGER ,       INTENT(IN)    :: Hndl
    3262. 

  3262.   CHARACTER*(*) :: DateStr
    3263. 

  3263.   CHARACTER*(*) :: VarName
    3264. 

  3264.   INTEGER                          :: Field(*)
    3265. 

  3265.   INTEGER                                      :: FieldType
    3266. 

  3266.   INTEGER                                      :: Comm
    3267. 

  3267.   INTEGER                                      :: IOComm
    3268. 

  3268.   INTEGER                                      :: DomainDesc
    3269. 

  3269.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    3270. 

  3270.   CHARACTER*(*)                                :: MemoryOrder
    3271. 

  3271.   CHARACTER*(*)                                :: Stagger
    3272. 

  3272.   CHARACTER*(*) , dimension (*)                :: DimNames
    3273. 

  3273.   INTEGER ,dimension(*)                        :: DomainStart, DomainEnd
    3274. 

  3274.   INTEGER ,dimension(*)                        :: MemoryStart, MemoryEnd
    3275. 

  3275.   INTEGER ,dimension(*)                        :: PatchStart,  PatchEnd
    3276. 

  3276.   INTEGER                                      :: Status
    3277. 

  3277.   LOGICAL donotdist
    3278. 

  3278.   INTEGER ndims, nproc
    3279. 

  3279. 

  3280.   CALL dim_from_memorder( MemoryOrder , ndims)
    3281. 

  3281.   CALL wrf_get_nproc( nproc )
    3282. 

  3282.   donotdist = donotdist_arg .OR. (nproc .EQ. 1)
    3283. 

  3283. 

  3284.   IF ( donotdist ) THEN
    3285. 

  3285.     CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3286. 

  3286.                DomainDesc , MemoryOrder , Stagger , DimNames ,                &
    3287. 

  3287.                DomainStart , DomainEnd ,                                      &
    3288. 

  3288.                MemoryStart , MemoryEnd ,                                      &
    3289. 

  3289.                PatchStart , PatchEnd ,                                        &
    3290. 

  3290.                Status )
    3291. 

  3291. 

  3292.   ELSE IF (FieldType .EQ. WRF_DOUBLE) THEN
    3293. 

  3293. 

  3294.      CALL call_pkg_and_dist_double ( fcn, update_arg,                            &
    3295. 

  3295.                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3296. 

  3296.                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3297. 

  3297.                DomainStart , DomainEnd ,                                    &
    3298. 

  3298.                MemoryStart , MemoryEnd ,                                    &
    3299. 

  3299.                PatchStart , PatchEnd ,                                      &
    3300. 

  3300.                Status )
    3301. 

  3301. 

  3302.   ELSE IF (FieldType .EQ. WRF_FLOAT) THEN
    3303. 

  3303. 

  3304.      CALL call_pkg_and_dist_real ( fcn, update_arg,                            &
    3305. 

  3305.                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3306. 

  3306.                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3307. 

  3307.                DomainStart , DomainEnd ,                                    &
    3308. 

  3308.                MemoryStart , MemoryEnd ,                                    &
    3309. 

  3309.                PatchStart , PatchEnd ,                                      &
    3310. 

  3310.                Status )
    3311. 

  3311. 

  3312.   ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
    3313. 

  3313. 

  3314.      CALL call_pkg_and_dist_int ( fcn, update_arg,                            &
    3315. 

  3315.                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3316. 

  3316.                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3317. 

  3317.                DomainStart , DomainEnd ,                                    &
    3318. 

  3318.                MemoryStart , MemoryEnd ,                                    &
    3319. 

  3319.                PatchStart , PatchEnd ,                                      &
    3320. 

  3320.                Status )
    3321. 

  3321. 

  3322.   ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
    3323. 

  3323. 

  3324.      CALL call_pkg_and_dist_logical ( fcn, update_arg,                            &
    3325. 

  3325.                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3326. 

  3326.                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3327. 

  3327.                DomainStart , DomainEnd ,                                    &
    3328. 

  3328.                MemoryStart , MemoryEnd ,                                    &
    3329. 

  3329.                PatchStart , PatchEnd ,                                      &
    3330. 

  3330.                Status )
    3331. 

  3331. 

  3332.   ENDIF
    3333. 

  3333.   RETURN
    3334. 

  3334. END SUBROUTINE call_pkg_and_dist
    3335. 

  3335. 

  3336. SUBROUTINE call_pkg_and_dist_real (  fcn, update_arg,                                             &
    3337. 

  3337.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3338. 

  3338.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3339. 

  3339.                                      DomainStart , DomainEnd ,                                    &
    3340. 

  3340.                                      MemoryStart , MemoryEnd ,                                    &
    3341. 

  3341.                                      PatchStart , PatchEnd ,                                      &
    3342. 

  3342.                                      Status )
    3343. 

  3343. !<DESCRIPTION>
    3344. 

  3344. !<PRE>
    3345. 

  3345. ! The call_pkg_and_dist* routines call an I/O function to read a field and then 
    3346. 

  3346. ! distribute or replicate the field across compute tasks.  
    3347. 

  3347. ! The sole purpose of this wrapper is to allocate a big real buffer and
    3348. 

  3348. ! pass it down to call_pkg_and_dist_generic() to do the actual work.
    3349. 

  3349. !</PRE>
    3350. 

  3350. !</DESCRIPTION>
    3351. 

  3351.   IMPLICIT NONE
    3352. 

  3352.   EXTERNAL fcn
    3353. 

  3353.   INTEGER ,       INTENT(IN)    :: Hndl
    3354. 

  3354.   LOGICAL ,       INTENT(IN)    :: update_arg
    3355. 

  3355.   CHARACTER*(*) :: DateStr
    3356. 

  3356.   CHARACTER*(*) :: VarName
    3357. 

  3357.   REAL    ,       INTENT(INOUT)    :: Field(*)
    3358. 

  3358.   INTEGER                       ,INTENT(IN)    :: FieldType
    3359. 

  3359.   INTEGER                       ,INTENT(INOUT) :: Comm
    3360. 

  3360.   INTEGER                       ,INTENT(INOUT) :: IOComm
    3361. 

  3361.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    3362. 

  3362.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    3363. 

  3363.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    3364. 

  3364.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    3365. 

  3365.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    3366. 

  3366.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    3367. 

  3367.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    3368. 

  3368.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    3369. 

  3369.   INTEGER                       ,INTENT(INOUT)   :: Status
    3370. 

  3370.   REAL, ALLOCATABLE :: globbuf (:)
    3371. 

  3371.   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
    3372. 

  3372.   INTEGER test
    3373. 

  3373.   CHARACTER*128 mess
    3374. 

  3374. 

  3375.   IF ( wrf_dm_on_monitor() ) THEN
    3376. 

  3376.     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ), &
    3377. 

  3377.               STAT=test )
    3378. 

  3378.     IF ( test .NE. 0 ) THEN
    3379. 

  3379.       write(mess,*)"module_io.b",'allocating globbuf ',&
    3380. 

  3380.            (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3)
    3381. 

  3381.       CALL wrf_error_fatal(mess)
    3382. 

  3382.     ENDIF
    3383. 

  3383.   ELSE
    3384. 

  3384.     ALLOCATE( globbuf( 1 ), STAT=test )
    3385. 

  3385.     IF ( test .NE. 0 ) THEN
    3386. 

  3386.       write(mess,*)"module_io.b",'allocating globbuf ',1
    3387. 

  3387.       CALL wrf_error_fatal(mess)
    3388. 

  3388.     ENDIF
    3389. 

  3389.   ENDIF
    3390. 

  3390. 

  3391.   globbuf = 0.
    3392. 

  3392. 

  3393.   CALL call_pkg_and_dist_generic (   fcn, globbuf FRSTELEM , update_arg,                          &
    3394. 

  3394.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3395. 

  3395.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3396. 

  3396.                                      DomainStart , DomainEnd ,                                    &
    3397. 

  3397.                                      MemoryStart , MemoryEnd ,                                    &
    3398. 

  3398.                                      PatchStart , PatchEnd ,                                      &
    3399. 

  3399.                                      Status )
    3400. 

  3400.   DEALLOCATE ( globbuf )
    3401. 

  3401.   RETURN
    3402. 

  3402. END SUBROUTINE call_pkg_and_dist_real
    3403. 

  3403. 

  3404. 

  3405. SUBROUTINE call_pkg_and_dist_double  (  fcn, update_arg ,                                            &
    3406. 

  3406.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3407. 

  3407.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3408. 

  3408.                                      DomainStart , DomainEnd ,                                    &
    3409. 

  3409.                                      MemoryStart , MemoryEnd ,                                    &
    3410. 

  3410.                                      PatchStart , PatchEnd ,                                      &
    3411. 

  3411.                                      Status )
    3412. 

  3412. !<DESCRIPTION>
    3413. 

  3413. !<PRE>
    3414. 

  3414. ! The call_pkg_and_dist* routines call an I/O function to read a field and then 
    3415. 

  3415. ! distribute or replicate the field across compute tasks.  
    3416. 

  3416. ! The sole purpose of this wrapper is to allocate a big double precision buffer 
    3417. 

  3417. ! and pass it down to call_pkg_and_dist_generic() to do the actual work.
    3418. 

  3418. !</PRE>
    3419. 

  3419. !</DESCRIPTION>
    3420. 

  3420.   IMPLICIT NONE
    3421. 

  3421.   EXTERNAL fcn
    3422. 

  3422.   INTEGER ,       INTENT(IN)    :: Hndl
    3423. 

  3423.   LOGICAL ,       INTENT(IN)    :: update_arg
    3424. 

  3424.   CHARACTER*(*) :: DateStr
    3425. 

  3425.   CHARACTER*(*) :: VarName
    3426. 

  3426.   DOUBLE PRECISION   ,       INTENT(INOUT)    :: Field(*)
    3427. 

  3427.   INTEGER                       ,INTENT(IN)    :: FieldType
    3428. 

  3428.   INTEGER                       ,INTENT(INOUT) :: Comm
    3429. 

  3429.   INTEGER                       ,INTENT(INOUT) :: IOComm
    3430. 

  3430.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    3431. 

  3431.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    3432. 

  3432.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    3433. 

  3433.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    3434. 

  3434.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    3435. 

  3435.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    3436. 

  3436.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    3437. 

  3437.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    3438. 

  3438.   INTEGER                       ,INTENT(INOUT)   :: Status
    3439. 

  3439.   DOUBLE PRECISION , ALLOCATABLE :: globbuf (:)
    3440. 

  3440.   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
    3441. 

  3441. 

  3442.   IF ( wrf_dm_on_monitor() ) THEN
    3443. 

  3443.     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
    3444. 

  3444.   ELSE
    3445. 

  3445.     ALLOCATE( globbuf( 1 ) )
    3446. 

  3446.   ENDIF
    3447. 

  3447. 

  3448.   globbuf = 0
    3449. 

  3449. 

  3450.   CALL call_pkg_and_dist_generic (   fcn, globbuf FRSTELEM , update_arg ,                         &
    3451. 

  3451.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3452. 

  3452.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3453. 

  3453.                                      DomainStart , DomainEnd ,                                    &
    3454. 

  3454.                                      MemoryStart , MemoryEnd ,                                    &
    3455. 

  3455.                                      PatchStart , PatchEnd ,                                      &
    3456. 

  3456.                                      Status )
    3457. 

  3457.   DEALLOCATE ( globbuf )
    3458. 

  3458.   RETURN
    3459. 

  3459. END SUBROUTINE call_pkg_and_dist_double
    3460. 

  3460. 

  3461. 

  3462. SUBROUTINE call_pkg_and_dist_int  (  fcn, update_arg ,                                            &
    3463. 

  3463.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3464. 

  3464.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3465. 

  3465.                                      DomainStart , DomainEnd ,                                    &
    3466. 

  3466.                                      MemoryStart , MemoryEnd ,                                    &
    3467. 

  3467.                                      PatchStart , PatchEnd ,                                      &
    3468. 

  3468.                                      Status )
    3469. 

  3469. !<DESCRIPTION>
    3470. 

  3470. !<PRE>
    3471. 

  3471. ! The call_pkg_and_dist* routines call an I/O function to read a field and then 
    3472. 

  3472. ! distribute or replicate the field across compute tasks.  
    3473. 

  3473. ! The sole purpose of this wrapper is to allocate a big integer buffer and 
    3474. 

  3474. ! pass it down to call_pkg_and_dist_generic() to do the actual work.
    3475. 

  3475. !</PRE>
    3476. 

  3476. !</DESCRIPTION>
    3477. 

  3477.   IMPLICIT NONE
    3478. 

  3478.   EXTERNAL fcn
    3479. 

  3479.   INTEGER ,       INTENT(IN)    :: Hndl
    3480. 

  3480.   LOGICAL ,       INTENT(IN)    :: update_arg
    3481. 

  3481.   CHARACTER*(*) :: DateStr
    3482. 

  3482.   CHARACTER*(*) :: VarName
    3483. 

  3483.   INTEGER    ,       INTENT(INOUT)    :: Field(*)
    3484. 

  3484.   INTEGER                       ,INTENT(IN)    :: FieldType
    3485. 

  3485.   INTEGER                       ,INTENT(INOUT) :: Comm
    3486. 

  3486.   INTEGER                       ,INTENT(INOUT) :: IOComm
    3487. 

  3487.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    3488. 

  3488.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    3489. 

  3489.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    3490. 

  3490.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    3491. 

  3491.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    3492. 

  3492.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    3493. 

  3493.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    3494. 

  3494.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    3495. 

  3495.   INTEGER                       ,INTENT(INOUT)   :: Status
    3496. 

  3496.   INTEGER , ALLOCATABLE :: globbuf (:)
    3497. 

  3497.   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
    3498. 

  3498. 

  3499.   IF ( wrf_dm_on_monitor() ) THEN
    3500. 

  3500.     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
    3501. 

  3501.   ELSE
    3502. 

  3502.     ALLOCATE( globbuf( 1 ) )
    3503. 

  3503.   ENDIF
    3504. 

  3504. 

  3505.   globbuf = 0
    3506. 

  3506. 

  3507.   CALL call_pkg_and_dist_generic (   fcn, globbuf FRSTELEM , update_arg ,                                  &
    3508. 

  3508.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3509. 

  3509.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3510. 

  3510.                                      DomainStart , DomainEnd ,                                    &
    3511. 

  3511.                                      MemoryStart , MemoryEnd ,                                    &
    3512. 

  3512.                                      PatchStart , PatchEnd ,                                      &
    3513. 

  3513.                                      Status )
    3514. 

  3514.   DEALLOCATE ( globbuf )
    3515. 

  3515.   RETURN
    3516. 

  3516. END SUBROUTINE call_pkg_and_dist_int
    3517. 

  3517. 

  3518. 

  3519. SUBROUTINE call_pkg_and_dist_logical  (  fcn, update_arg ,                                            &
    3520. 

  3520.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3521. 

  3521.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3522. 

  3522.                                      DomainStart , DomainEnd ,                                    &
    3523. 

  3523.                                      MemoryStart , MemoryEnd ,                                    &
    3524. 

  3524.                                      PatchStart , PatchEnd ,                                      &
    3525. 

  3525.                                      Status )
    3526. 

  3526. !<DESCRIPTION>
    3527. 

  3527. !<PRE>
    3528. 

  3528. ! The call_pkg_and_dist* routines call an I/O function to read a field and then 
    3529. 

  3529. ! distribute or replicate the field across compute tasks.  
    3530. 

  3530. ! The sole purpose of this wrapper is to allocate a big logical buffer and 
    3531. 

  3531. ! pass it down to call_pkg_and_dist_generic() to do the actual work.
    3532. 

  3532. !</PRE>
    3533. 

  3533. !</DESCRIPTION>
    3534. 

  3534.   IMPLICIT NONE
    3535. 

  3535.   EXTERNAL fcn
    3536. 

  3536.   INTEGER ,       INTENT(IN)    :: Hndl
    3537. 

  3537.   LOGICAL ,       INTENT(IN)    :: update_arg
    3538. 

  3538.   CHARACTER*(*) :: DateStr
    3539. 

  3539.   CHARACTER*(*) :: VarName
    3540. 

  3540.   logical    ,       INTENT(INOUT)    :: Field(*)
    3541. 

  3541.   INTEGER                       ,INTENT(IN)    :: FieldType
    3542. 

  3542.   INTEGER                       ,INTENT(INOUT) :: Comm
    3543. 

  3543.   INTEGER                       ,INTENT(INOUT) :: IOComm
    3544. 

  3544.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    3545. 

  3545.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    3546. 

  3546.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    3547. 

  3547.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    3548. 

  3548.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    3549. 

  3549.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    3550. 

  3550.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    3551. 

  3551.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    3552. 

  3552.   INTEGER                       ,INTENT(INOUT)   :: Status
    3553. 

  3553.   LOGICAL , ALLOCATABLE :: globbuf (:)
    3554. 

  3554.   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
    3555. 

  3555. 

  3556.   IF ( wrf_dm_on_monitor() ) THEN
    3557. 

  3557.     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
    3558. 

  3558.   ELSE
    3559. 

  3559.     ALLOCATE( globbuf( 1 ) )
    3560. 

  3560.   ENDIF
    3561. 

  3561. 

  3562.   globbuf = .false.
    3563. 

  3563. 

  3564.   CALL call_pkg_and_dist_generic (   fcn, globbuf FRSTELEM , update_arg ,                         &
    3565. 

  3565.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3566. 

  3566.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3567. 

  3567.                                      DomainStart , DomainEnd ,                                    &
    3568. 

  3568.                                      MemoryStart , MemoryEnd ,                                    &
    3569. 

  3569.                                      PatchStart , PatchEnd ,                                      &
    3570. 

  3570.                                      Status )
    3571. 

  3571.   DEALLOCATE ( globbuf )
    3572. 

  3572.   RETURN
    3573. 

  3573. END SUBROUTINE call_pkg_and_dist_logical
    3574. 

  3574. 

  3575. SUBROUTINE call_pkg_and_dist_generic (   fcn, globbuf , update_arg ,                                  &
    3576. 

  3576.                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
    3577. 

  3577.                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
    3578. 

  3578.                                      DomainStart , DomainEnd ,                                    &
    3579. 

  3579.                                      MemoryStart , MemoryEnd ,                                    &
    3580. 

  3580.                                      PatchStart , PatchEnd ,                                      &
    3581. 

  3581.                                      Status )
    3582. 

  3582. 

  3583. !<DESCRIPTION>
    3584. 

  3584. !<PRE>
    3585. 

  3585. ! The call_pkg_and_dist* routines call an I/O function to read a field and then 
    3586. 

  3586. ! distribute or replicate the field across compute tasks.  
    3587. 

  3587. ! This routine calls I/O function fcn to read the field from disk and then calls 
    3588. 

  3588. ! the distributed memory communication routines that distribute or replicate the 
    3589. 

  3589. ! array.  
    3590. 

  3590. !</PRE>
    3591. 

  3591. !</DESCRIPTION>
    3592. 

  3592.   USE module_state_description
    3593. 

  3593.   USE module_driver_constants
    3594. 

  3594.   USE module_io
    3595. 

  3595.   IMPLICIT NONE
    3596. 

  3596. #include "wrf_io_flags.h"
    3597. 

  3597. #if defined( DM_PARALLEL ) && ! defined(STUBMPI)
    3598. 

  3598. include "mpif.h"
    3599. 

  3599. #endif
    3600. 

  3600. 

  3601.   EXTERNAL fcn
    3602. 

  3602.   REAL, DIMENSION(*) ::  globbuf
    3603. 

  3603.   INTEGER ,       INTENT(IN)    :: Hndl
    3604. 

  3604.   LOGICAL ,       INTENT(IN)    :: update_arg
    3605. 

  3605.   CHARACTER*(*) :: DateStr
    3606. 

  3606.   CHARACTER*(*) :: VarName
    3607. 

  3607.   REAL                           :: Field(*)
    3608. 

  3608.   INTEGER                       ,INTENT(IN)    :: FieldType
    3609. 

  3609.   INTEGER                       ,INTENT(INOUT) :: Comm
    3610. 

  3610.   INTEGER                       ,INTENT(INOUT) :: IOComm
    3611. 

  3611.   INTEGER                       ,INTENT(IN)    :: DomainDesc
    3612. 

  3612.   LOGICAL, DIMENSION(4)                        :: bdy_mask
    3613. 

  3613.   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
    3614. 

  3614.   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
    3615. 

  3615.   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
    3616. 

  3616.   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
    3617. 

  3617.   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
    3618. 

  3618.   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
    3619. 

  3619.   INTEGER                       ,INTENT(OUT)   :: Status
    3620. 

  3620.   CHARACTER*3 MemOrd
    3621. 

  3621.   LOGICAL, EXTERNAL :: has_char
    3622. 

  3622.   INTEGER ids, ide, jds, jde, kds, kde
    3623. 

  3623.   INTEGER ims, ime, jms, jme, kms, kme
    3624. 

  3624.   INTEGER ips, ipe, jps, jpe, kps, kpe
    3625. 

  3625.   INTEGER , dimension(3)                       :: dom_end_rev
    3626. 

  3626.   INTEGER memsize
    3627. 

  3627.   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
    3628. 

  3628.   INTEGER, EXTERNAL :: wrf_dm_monitor_rank
    3629. 

  3629. 

  3630.   INTEGER lx, lx2, i,j,k ,idx,idx2
    3631. 

  3631.   INTEGER my_count, nproc, communicator, ierr, my_displ
    3632. 

  3632. 

  3633.   INTEGER, ALLOCATABLE :: counts(:), displs(:)
    3634. 

  3634. 

  3635.   LOGICAL distributed_field
    3636. 

  3636.   INTEGER collective_root
    3637. 

  3637. 

  3638.   CALL lower_case( MemoryOrder, MemOrd )
    3639. 

  3639. 

  3640.   collective_root = wrf_dm_monitor_rank()
    3641. 

  3641. 

  3642.   CALL wrf_get_nproc( nproc )
    3643. 

  3643.   CALL wrf_get_dm_communicator ( communicator )
    3644. 

  3644. 

  3645.   ALLOCATE(displs( nproc ))
    3646. 

  3646.   ALLOCATE(counts( nproc ))
    3647. 

  3647. 

  3648.   dom_end_rev(1) = DomainEnd(1)
    3649. 

  3649.   dom_end_rev(2) = DomainEnd(2)
    3650. 

  3650.   dom_end_rev(3) = DomainEnd(3)
    3651. 

  3651. 

  3652.   SELECT CASE (TRIM(MemOrd))
    3653. 

  3653.     CASE (  'xzy' )
    3654. 

  3654.       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
    3655. 

  3655.       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
    3656. 

  3656.       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
    3657. 

  3657.     CASE (  'zxy' )
    3658. 

  3658.       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
    3659. 

  3659.       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
    3660. 

  3660.       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
    3661. 

  3661.     CASE (  'xyz' )
    3662. 

  3662.       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
    3663. 

  3663.       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
    3664. 

  3664.       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
    3665. 

  3665.     CASE (  'xy' )
    3666. 

  3666.       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
    3667. 

  3667.       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
    3668. 

  3668.     CASE (  'yxz' )
    3669. 

  3669.       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
    3670. 

  3670.       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
    3671. 

  3671.       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
    3672. 

  3672.     CASE (  'yx' )
    3673. 

  3673.       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
    3674. 

  3674.       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
    3675. 

  3675.     CASE DEFAULT
    3676. 

  3676.       ! do nothing; the boundary orders and others either dont care or set themselves
    3677. 

  3677.   END SELECT
    3678. 

  3678. 

  3679.   data_ordering : SELECT CASE ( model_data_order )
    3680. 

  3680.     CASE  ( DATA_ORDER_XYZ )
    3681. 

  3681.        ids=DomainStart(1); ide=dom_end_rev(1); jds=DomainStart(2); jde=dom_end_rev(2); kds=DomainStart(3); kde=dom_end_rev(3);
    3682. 

  3682.        ims=MemoryStart(1); ime=  MemoryEnd(1); jms=MemoryStart(2); jme=  MemoryEnd(2); kms=MemoryStart(3); kme=  MemoryEnd(3);
    3683. 

  3683.        ips= PatchStart(1); ipe=   PatchEnd(1); jps= PatchStart(2); jpe=   PatchEnd(2); kps= PatchStart(3); kpe=   PatchEnd(3);
    3684. 

  3684.     CASE  ( DATA_ORDER_YXZ )
    3685. 

  3685.        ids=DomainStart(2); ide=dom_end_rev(2); jds=DomainStart(1); jde=dom_end_rev(1); kds=DomainStart(3); kde=dom_end_rev(3);
    3686. 

  3686.        ims=MemoryStart(2); ime=  MemoryEnd(2); jms=MemoryStart(1); jme=  MemoryEnd(1); kms=MemoryStart(3); kme=  MemoryEnd(3);
    3687. 

  3687.        ips= PatchStart(2); ipe=   PatchEnd(2); jps= PatchStart(1); jpe=   PatchEnd(1); kps= PatchStart(3); kpe=   PatchEnd(3);
    3688. 

  3688.     CASE  ( DATA_ORDER_ZXY )
    3689. 

  3689.        ids=DomainStart(2); ide=dom_end_rev(2); jds=DomainStart(3); jde=dom_end_rev(3); kds=DomainStart(1); kde=dom_end_rev(1);
    3690. 

  3690.        ims=MemoryStart(2); ime=  MemoryEnd(2); jms=MemoryStart(3); jme=  MemoryEnd(3); kms=MemoryStart(1); kme=  MemoryEnd(1);
    3691. 

  3691.        ips= PatchStart(2); ipe=   PatchEnd(2); jps= PatchStart(3); jpe=   PatchEnd(3); kps= PatchStart(1); kpe=   PatchEnd(1);
    3692. 

  3692.     CASE  ( DATA_ORDER_ZYX )
    3693. 

  3693.        ids=DomainStart(3); ide=dom_end_rev(3); jds=DomainStart(2); jde=dom_end_rev(2); kds=DomainStart(1); kde=dom_end_rev(1);
    3694. 

  3694.        ims=MemoryStart(3); ime=  MemoryEnd(3); jms=MemoryStart(2); jme=  MemoryEnd(2); kms=MemoryStart(1); kme=  MemoryEnd(1);
    3695. 

  3695.        ips= PatchStart(3); ipe=   PatchEnd(3); jps= PatchStart(2); jpe=   PatchEnd(2); kps= PatchStart(1); kpe=   PatchEnd(1);
    3696. 

  3696.     CASE  ( DATA_ORDER_XZY )
    3697. 

  3697.        ids=DomainStart(1); ide=dom_end_rev(1); jds=DomainStart(3); jde=dom_end_rev(3); kds=DomainStart(2); kde=dom_end_rev(2);
    3698. 

  3698.        ims=MemoryStart(1); ime=  MemoryEnd(1); jms=MemoryStart(3); jme=  MemoryEnd(3); kms=MemoryStart(2); kme=  MemoryEnd(2);
    3699. 

  3699.        ips= PatchStart(1); ipe=   PatchEnd(1); jps= PatchStart(3); jpe=   PatchEnd(3); kps= PatchStart(2); kpe=   PatchEnd(2);
    3700. 

  3700.     CASE  ( DATA_ORDER_YZX )
    3701. 

  3701.        ids=DomainStart(3); ide=dom_end_rev(3); jds=DomainStart(1); jde=dom_end_rev(1); kds=DomainStart(2); kde=dom_end_rev(2);
    3702. 

  3702.        ims=MemoryStart(3); ime=  MemoryEnd(3); jms=MemoryStart(1); jme=  MemoryEnd(1); kms=MemoryStart(2); kme=  MemoryEnd(2);
    3703. 

  3703.        ips= PatchStart(3); ipe=   PatchEnd(3); jps= PatchStart(1); jpe=   PatchEnd(1); kps= PatchStart(2); kpe=   PatchEnd(2);
    3704. 

  3704.   END SELECT data_ordering
    3705. 

  3705. 

  3706. 

  3707.   SELECT CASE (MemOrd)
    3708. 

  3708. #ifndef STUBMPI
    3709. 

  3709.     CASE ( 'xzy', 'yzx', 'xyz', 'yxz', 'zxy', 'zyx', 'xy', 'yx' )
    3710. 

  3710.       distributed_field = .TRUE.
    3711. 

  3711.     CASE ( 'xsz', 'xez', 'xs', 'xe' )
    3712. 

  3712.       CALL are_bdys_distributed( distributed_field )
    3713. 

  3713.     CASE ( 'ysz', 'yez', 'ys', 'ye' )
    3714. 

  3714.       CALL are_bdys_distributed( distributed_field )
    3715. 

  3715. #endif
    3716. 

  3716.     CASE DEFAULT
    3717. 

  3717.       ! all other memory orders are replicated
    3718. 

  3718.       distributed_field = .FALSE.
    3719. 

  3719.   END SELECT
    3720. 

  3720. 

  3721.   IF ( distributed_field ) THEN
    3722. 

  3722. 

  3723. ! added 8/2004 for interfaces, like MCEL, that want the old values so they can be updated
    3724. 

  3724.     IF ( update_arg ) THEN
    3725. 

  3725.       SELECT CASE (TRIM(MemOrd))
    3726. 

  3726.         CASE (  'xzy','zxy','xyz','yxz','xy','yx' )
    3727. 

  3727.           IF ( FieldType .EQ. WRF_DOUBLE ) THEN
    3728. 

  3728.             CALL wrf_patch_to_global_double ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
    3729. 

  3729.                DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
    3730. 

  3730.                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
    3731. 

  3731.                PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
    3732. 

  3732.           ELSE IF (  FieldType .EQ. WRF_FLOAT ) THEN
    3733. 

  3733.             CALL wrf_patch_to_global_real ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
    3734. 

  3734.                DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
    3735. 

  3735.                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
    3736. 

  3736.                PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
    3737. 

  3737.           ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
    3738. 

  3738.             CALL wrf_patch_to_global_integer ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
    3739. 

  3739.                DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
    3740. 

  3740.                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
    3741. 

  3741.                PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
    3742. 

  3742.           ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
    3743. 

  3743.             CALL wrf_patch_to_global_logical ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
    3744. 

  3744.                DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
    3745. 

  3745.                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
    3746. 

  3746.                PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
    3747. 

  3747.           ENDIF
    3748. 

  3748.         CASE DEFAULT
    3749. 

  3749.       END SELECT
    3750. 

  3750.     ENDIF
    3751. 

  3751. 

  3752.     IF ( wrf_dm_on_monitor()) THEN
    3753. 

  3753.       CALL fcn ( Hndl , DateStr , VarName , globbuf , FieldType , Comm , IOComm , &
    3754. 

  3754.                  DomainDesc , MemoryOrder , Stagger , DimNames ,                  &
    3755. 

  3755.                  DomainStart , DomainEnd ,                                        &
    3756. 

  3756.                  DomainStart , dom_end_rev ,                                        &
    3757. 

  3757.                  DomainStart , DomainEnd ,                                          &
    3758. 

  3758.                  Status )
    3759. 

  3759.     ENDIF
    3760. 

  3760. 

  3761.     CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    3762. 

  3762. 

  3763.     CALL lower_case( MemoryOrder, MemOrd )
    3764. 

  3764. 

  3765. #if defined(DM_PARALLEL) && !defined(STUBMPI)
    3766. 

  3766. ! handle boundaries separately
    3767. 

  3767.     IF ( TRIM(MemOrd) .EQ. 'xsz' .OR. TRIM(MemOrd) .EQ. 'xez' .OR. &
    3768. 

  3768.          TRIM(MemOrd) .EQ. 'xs'  .OR. TRIM(MemOrd) .EQ. 'xe'  .OR. &
    3769. 

  3769.          TRIM(MemOrd) .EQ. 'ysz' .OR. TRIM(MemOrd) .EQ. 'yez' .OR. &
    3770. 

  3770.          TRIM(MemOrd) .EQ. 'ys'  .OR. TRIM(MemOrd) .EQ. 'ye'    ) THEN
    3771. 

  3771. 

  3772.       IF ( TRIM(MemOrd) .EQ. 'xsz' .OR. TRIM(MemOrd) .EQ. 'xez' .OR. &
    3773. 

  3773.            TRIM(MemOrd) .EQ. 'xs'  .OR. TRIM(MemOrd) .EQ. 'xe'    ) THEN
    3774. 

  3774. 

  3775.        jds=DomainStart(1); jde=dom_end_rev(1); ids=DomainStart(3); ide=dom_end_rev(3); kds=DomainStart(2); kde=dom_end_rev(2);
    3776. 

  3776.        jms=MemoryStart(1); jme=  MemoryEnd(1); ims=MemoryStart(3); ime=  MemoryEnd(3); kms=MemoryStart(2); kme=  MemoryEnd(2);
    3777. 

  3777.        jps= PatchStart(1); jpe=   PatchEnd(1); ips= PatchStart(3); ipe=   PatchEnd(3); kps= PatchStart(2); kpe=   PatchEnd(2);
    3778. 

  3778. 

  3779.         IF ( nproc .GT. 1 ) THEN
    3780. 

  3780. 

  3781. ! Will assume that the i,j, and k dimensions correspond to the model_data_order specified by the registry -- 
    3782. 

  3782. ! eg. i is (1), j is (3), and k is (2) for XZY -- and that when these are passed in for xs/xe boundary arrays (left and right
    3783. 

  3783. ! sides of domain) the j is fully dimensioned, i is the bdy_width, and k is k. corresponding arrangement for ys/ye
    3784. 

  3784. ! boundaries (bottom and top).  Note, however, that for the boundary arrays themselves, the innermost dimension is always
    3785. 

  3785. ! the "full" dimension: for xs/xe, dimension 1 of the boundary arrays is j. For ys/ye, it's i. So there's a potential
    3786. 

  3786. ! for confusion between the MODEL storage order, and which of the sd31:ed31/sd32:ed32/sd33:ed33 framework dimensions
    3787. 

  3787. ! correspond to X/Y/Z as determined by the Registry dimespec definitions and what the storage order of the boundary
    3788. 

  3788. ! slab arrays are (which depends on which boundaries they represent).  The k memory and domain dimensions must be set
    3789. 

  3789. ! properly for 2d (ks=1, ke=1) versus 3d fields.
    3790. 

  3790. 

  3791. #if 1
    3792. 

  3792.           IF ( (MemOrd(1:2) .EQ. 'xs' .AND. bdy_mask( P_XSB )) .OR.     &
    3793. 

  3793.                (MemOrd(1:2) .EQ. 'xe' .AND. bdy_mask( P_XEB ))       ) THEN
    3794. 

  3794.             my_displ = jps-1         
    3795. 

  3795.             my_count = jpe-jps+1
    3796. 

  3796.           ELSE
    3797. 

  3797.             my_displ = 0
    3798. 

  3798.             my_count = 0
    3799. 

  3799.           ENDIF
    3800. 

  3800. #else
    3801. 

  3801.           IF ( (MemOrd(1:2) .EQ. 'xs' ) .OR.     &
    3802. 

  3802.                (MemOrd(1:2) .EQ. 'xe' )       ) THEN
    3803. 

  3803.             my_displ = jps-1         
    3804. 

  3804.             my_count = jpe-jps+1
    3805. 

  3805.           ELSE
    3806. 

  3806.             my_displ = 0
    3807. 

  3807.             my_count = 0
    3808. 

  3808.           ENDIF
    3809. 

  3809. #endif
    3810. 

  3810. 

  3811.           CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
    3812. 

  3812.           CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
    3813. 

  3813. 

  3814.           do i = ips,ipe    ! bdy_width
    3815. 

  3815.           do k = kds,kde    ! levels
    3816. 

  3816.              lx   = jme-jms+1
    3817. 

  3817.              lx2  = jde-jds+1
    3818. 

  3818.              idx  = lx*((k-1)+(i-1)*(kme-kms+1))
    3819. 

  3819.              idx2 = lx2*((k-1)+(i-1)*(kde-kds+1))
    3820. 

  3820.              IF ( FieldType .EQ. WRF_DOUBLE  ) THEN
    3821. 

  3821.                CALL wrf_scatterv_double (                        &
    3822. 

  3822.                                globbuf, 1+idx2 ,                &    ! sendbuf
    3823. 

  3823.                                counts                         , &    ! sendcounts
    3824. 

  3824.                                Field, jps-jms+1+idx ,       &
    3825. 

  3825.                                my_count ,                       &    ! recvcount
    3826. 

  3826.                                displs                         , &    ! displs
    3827. 

  3827.                                collective_root                , &    ! root
    3828. 

  3828.                                communicator                   , &    ! communicator
    3829. 

  3829.                                ierr )
    3830. 

  3830.              ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
    3831. 

  3831. 

  3832.                CALL wrf_scatterv_real (                          &
    3833. 

  3833.                                globbuf, 1+idx2 ,                &    ! sendbuf
    3834. 

  3834.                                counts                         , &    ! sendcounts
    3835. 

  3835.                                Field, jps-jms+1+idx ,       &
    3836. 

  3836.                                my_count ,                       &    ! recvcount
    3837. 

  3837.                                displs                         , &    ! displs
    3838. 

  3838.                                collective_root                , &    ! root
    3839. 

  3839.                                communicator                   , &    ! communicator
    3840. 

  3840.                                ierr )
    3841. 

  3841. 

  3842.              ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
    3843. 

  3843.                CALL wrf_scatterv_integer (                       &
    3844. 

  3844.                                globbuf, 1+idx2 ,                &    ! sendbuf
    3845. 

  3845.                                counts                         , &    ! sendcounts
    3846. 

  3846.                                Field, jps-jms+1+idx ,       &
    3847. 

  3847.                                my_count ,                       &    ! recvcount
    3848. 

  3848.                                displs                         , &    ! displs
    3849. 

  3849.                                collective_root                , &    ! root
    3850. 

  3850.                                communicator                   , &    ! communicator
    3851. 

  3851.                                ierr )
    3852. 

  3852.              ENDIF
    3853. 

  3853.           enddo
    3854. 

  3854.           enddo
    3855. 

  3855.         ENDIF
    3856. 

  3856.       ENDIF
    3857. 

  3857. 

  3858.       IF ( TRIM(MemOrd) .EQ. 'ysz' .OR. TRIM(MemOrd) .EQ. 'yez' .OR. &
    3859. 

  3859.            TRIM(MemOrd) .EQ. 'ys'  .OR. TRIM(MemOrd) .EQ. 'ye'    ) THEN
    3860. 

  3860. 

  3861. 

  3862.        ids=DomainStart(1); ide=dom_end_rev(1); jds=DomainStart(3); jde=dom_end_rev(3); kds=DomainStart(2); kde=dom_end_rev(2);
    3863. 

  3863.        ims=MemoryStart(1); ime=  MemoryEnd(1); jms=MemoryStart(3); jme=  MemoryEnd(3); kms=MemoryStart(2); kme=  MemoryEnd(2);
    3864. 

  3864.        ips= PatchStart(1); ipe=   PatchEnd(1); jps= PatchStart(3); jpe=   PatchEnd(3); kps= PatchStart(2); kpe=   PatchEnd(2);
    3865. 

  3865. 

  3866.         IF ( nproc .GT. 1 ) THEN
    3867. 

  3867. 

  3868. #if 1
    3869. 

  3869.           IF ( (MemOrd(1:2) .EQ. 'ys' .AND. bdy_mask( P_YSB )) .OR.     &
    3870. 

  3870.                (MemOrd(1:2) .EQ. 'ye' .AND. bdy_mask( P_YEB ))       ) THEN
    3871. 

  3871.             my_displ = ips-1
    3872. 

  3872.             my_count = ipe-ips+1
    3873. 

  3873.            ELSE
    3874. 

  3874.              my_displ = 0
    3875. 

  3875.              my_count = 0
    3876. 

  3876.           ENDIF
    3877. 

  3877. #else
    3878. 

  3878.           IF ( (MemOrd(1:2) .EQ. 'ys' ) .OR.     &
    3879. 

  3879.                (MemOrd(1:2) .EQ. 'ye' )       ) THEN
    3880. 

  3880.             my_displ = ips-1
    3881. 

  3881.             my_count = ipe-ips+1
    3882. 

  3882.           ELSE
    3883. 

  3883.             my_displ = 0
    3884. 

  3884.             my_count = 0
    3885. 

  3885.           ENDIF
    3886. 

  3886. #endif
    3887. 

  3887. 

  3888.           CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
    3889. 

  3889.           CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
    3890. 

  3890. 

  3891.           do j = jds,jde    ! bdy_width
    3892. 

  3892.           do k = kds,kde    ! levels
    3893. 

  3893.              lx   = ime-ims+1
    3894. 

  3894.              lx2  = ide-ids+1
    3895. 

  3895.              idx  = lx*((k-1)+(j-1)*(kme-kms+1))
    3896. 

  3896.              idx2 = lx2*((k-1)+(j-1)*(kde-kds+1))
    3897. 

  3897. 

  3898.              IF ( FieldType .EQ. WRF_DOUBLE  ) THEN
    3899. 

  3899.                CALL wrf_scatterv_double (                        &
    3900. 

  3900.                                globbuf, 1+idx2 ,                &    ! sendbuf
    3901. 

  3901.                                counts                         , &    ! sendcounts
    3902. 

  3902.                                Field, ips-ims+1+idx ,       &
    3903. 

  3903.                                my_count ,                       &    ! recvcount
    3904. 

  3904.                                displs                         , &    ! displs
    3905. 

  3905.                                collective_root                , &    ! root
    3906. 

  3906.                                communicator                   , &    ! communicator
    3907. 

  3907.                                ierr )
    3908. 

  3908.              ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
    3909. 

  3909.                CALL wrf_scatterv_real (                          &
    3910. 

  3910.                                globbuf, 1+idx2 ,                &    ! sendbuf
    3911. 

  3911.                                counts                         , &    ! sendcounts
    3912. 

  3912.                                Field, ips-ims+1+idx ,       &
    3913. 

  3913.                                my_count ,                       &    ! recvcount
    3914. 

  3914.                                displs                         , &    ! displs
    3915. 

  3915.                                collective_root                , &    ! root
    3916. 

  3916.                                communicator                   , &    ! communicator
    3917. 

  3917.                                ierr )
    3918. 

  3918.              ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
    3919. 

  3919.                CALL wrf_scatterv_integer (                       &
    3920. 

  3920.                                globbuf, 1+idx2 ,                &    ! sendbuf
    3921. 

  3921.                                counts                         , &    ! sendcounts
    3922. 

  3922.                                Field, ips-ims+1+idx ,       &
    3923. 

  3923.                                my_count ,                       &    ! recvcount
    3924. 

  3924.                                displs                         , &    ! displs
    3925. 

  3925.                                collective_root                , &    ! root
    3926. 

  3926.                                communicator                   , &    ! communicator
    3927. 

  3927.                                ierr )
    3928. 

  3928.              ENDIF
    3929. 

  3929.           enddo
    3930. 

  3930.           enddo
    3931. 

  3931.         ENDIF
    3932. 

  3932.       ENDIF
    3933. 

  3933. 

  3934.     ELSE  ! not a boundary 
    3935. 

  3935.   
    3936. 

  3936.       IF ( FieldType .EQ. WRF_DOUBLE ) THEN
    3937. 

  3937. 

  3938.         SELECT CASE (MemOrd)
    3939. 

  3939.         CASE ( 'xzy','xyz','yxz','zxy' )
    3940. 

  3940.           CALL wrf_global_to_patch_double (  globbuf,  Field  , DomainDesc, Stagger, MemOrd ,    &
    3941. 

  3941.              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
    3942. 

  3942.              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
    3943. 

  3943.              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3)  )
    3944. 

  3944.         CASE ( 'xy','yx' )
    3945. 

  3945.           CALL wrf_global_to_patch_double (  globbuf, Field ,  DomainDesc, Stagger, MemOrd ,  &
    3946. 

  3946.              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1            , 1 , &
    3947. 

  3947.              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1            , 1 , &
    3948. 

  3948.              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1            , 1   )
    3949. 

  3949.         END SELECT
    3950. 

  3950. 

  3951.       ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
    3952. 

  3952. 

  3953.         SELECT CASE (MemOrd)
    3954. 

  3954.         CASE ( 'xzy','xyz','yxz','zxy' )
    3955. 

  3955.           CALL wrf_global_to_patch_real (  globbuf,  Field  , DomainDesc, Stagger, MemOrd ,    &
    3956. 

  3956.              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
    3957. 

  3957.              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
    3958. 

  3958.              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3)  )
    3959. 

  3959.         CASE ( 'xy','yx' )
    3960. 

  3960.           CALL wrf_global_to_patch_real (  globbuf, Field ,  DomainDesc, Stagger, MemOrd ,  &
    3961. 

  3961.              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1            , 1 , &
    3962. 

  3962.              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1            , 1 , &
    3963. 

  3963.              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1            , 1   )
    3964. 

  3964.         END SELECT
    3965. 

  3965. 

  3966.       ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
    3967. 

  3967. 

  3968.         SELECT CASE (MemOrd)
    3969. 

  3969.         CASE ( 'xzy','xyz','yxz','zxy' )
    3970. 

  3970.           CALL wrf_global_to_patch_integer (  globbuf,  Field  , DomainDesc, Stagger, MemOrd ,    &
    3971. 

  3971.              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
    3972. 

  3972.              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
    3973. 

  3973.              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3)  )
    3974. 

  3974.         CASE ( 'xy','yx' )
    3975. 

  3975.           CALL wrf_global_to_patch_integer (  globbuf, Field ,  DomainDesc, Stagger, MemOrd ,  &
    3976. 

  3976.              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1            , 1 , &
    3977. 

  3977.              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1            , 1 , &
    3978. 

  3978.              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1            , 1   )
    3979. 

  3979.         END SELECT
    3980. 

  3980. 

  3981.       ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
    3982. 

  3982. 

  3983.         SELECT CASE (MemOrd)
    3984. 

  3984.         CASE ( 'xzy','xyz','yxz','zxy' )
    3985. 

  3985.           CALL wrf_global_to_patch_logical (  globbuf,  Field  , DomainDesc, Stagger, MemOrd ,    &
    3986. 

  3986.              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
    3987. 

  3987.              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
    3988. 

  3988.              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3)  )
    3989. 

  3989.         CASE ( 'xy','yx' )
    3990. 

  3990.           CALL wrf_global_to_patch_logical (  globbuf, Field ,  DomainDesc, Stagger, MemOrd ,  &
    3991. 

  3991.              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1            , 1 , &
    3992. 

  3992.              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1            , 1 , &
    3993. 

  3993.              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1            , 1   )
    3994. 

  3994.         END SELECT
    3995. 

  3995. 

  3996.       ENDIF
    3997. 

  3997.     ENDIF
    3998. 

  3998. #endif
    3999. 

  3999. 

  4000.   ELSE ! not a distributed field
    4001. 

  4001. 

  4002.     IF ( wrf_dm_on_monitor()) THEN
    4003. 

  4003.       CALL fcn ( Hndl , DateStr , VarName , Field   , FieldType , Comm , IOComm , &
    4004. 

  4004.                  DomainDesc , MemoryOrder , Stagger , DimNames ,                  &
    4005. 

  4005.                  DomainStart , DomainEnd ,                                        &
    4006. 

  4006.                  MemoryStart , MemoryEnd ,                                        &
    4007. 

  4007.                  PatchStart  , PatchEnd  ,                                        &
    4008. 

  4008.                  Status )
    4009. 

  4009.     ENDIF
    4010. 

  4010.     CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
    4011. 

  4011.     memsize = (MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)
    4012. 

  4012.     IF ( FieldType .EQ. WRF_DOUBLE ) THEN 
    4013. 

  4013.       CALL wrf_dm_bcast_bytes( Field , DWORDSIZE*memsize )
    4014. 

  4014.     ELSE IF ( FieldType .EQ. WRF_FLOAT) THEN
    4015. 

  4015.       CALL wrf_dm_bcast_bytes( Field , RWORDSIZE*memsize )
    4016. 

  4016.     ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
    4017. 

  4017.       CALL wrf_dm_bcast_bytes( Field , IWORDSIZE*memsize )
    4018. 

  4018.     ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
    4019. 

  4019.       CALL wrf_dm_bcast_bytes( Field , LWORDSIZE*memsize )
    4020. 

  4020.     ENDIF
    4021. 

  4021. 

  4022.   ENDIF
    4023. 

  4023. 

  4024.   DEALLOCATE(displs)
    4025. 

  4025.   DEALLOCATE(counts)
    4026. 

  4026.   RETURN
    4027. 

  4027. END SUBROUTINE call_pkg_and_dist_generic
    4028. 

  4028. 

  4029. !!!!!!  Miscellaneous routines
    4030. 

  4030. 

  4031. ! stole these routines from io_netcdf external package; changed names to avoid collisions
    4032. 

  4032. SUBROUTINE dim_from_memorder(MemoryOrder,NDim)
    4033. 

  4033. !<DESCRIPTION>
    4034. 

  4034. !<PRE>
    4035. 

  4035. ! Decodes array ranks from memory order.  
    4036. 

  4036. !</PRE>
    4037. 

  4037. !</DESCRIPTION>
    4038. 

  4038.   CHARACTER*(*) ,INTENT(IN)  :: MemoryOrder
    4039. 

  4039.   INTEGER       ,INTENT(OUT) :: NDim
    4040. 

  4040. !Local
    4041. 

  4041.   CHARACTER*3                :: MemOrd
    4042. 

  4042. !
    4043. 

  4043.   CALL Lower_Case(MemoryOrder,MemOrd)
    4044. 

  4044.   SELECT CASE (MemOrd)
    4045. 

  4045.     CASE ('xyz','xzy','yxz','yzx','zxy','zyx')
    4046. 

  4046.       NDim = 3
    4047. 

  4047.     CASE ('xy','yx')
    4048. 

  4048.       NDim = 2
    4049. 

  4049.     CASE ('z','c','0')
    4050. 

  4050.       NDim = 1
    4051. 

  4051.     CASE DEFAULT
    4052. 

  4052.       NDim = 0
    4053. 

  4053.       RETURN
    4054. 

  4054.   END SELECT
    4055. 

  4055.   RETURN
    4056. 

  4056. END SUBROUTINE dim_from_memorder
    4057. 

  4057. 

  4058. SUBROUTINE lower_case(MemoryOrder,MemOrd)
    4059. 

  4059. !<DESCRIPTION>
    4060. 

  4060. !<PRE>
    4061. 

  4061. ! Translates upper-case characters to lower-case.  
    4062. 

  4062. !</PRE>
    4063. 

  4063. !</DESCRIPTION>
    4064. 

  4064.   CHARACTER*(*) ,INTENT(IN)  :: MemoryOrder
    4065. 

  4065.   CHARACTER*(*) ,INTENT(OUT) :: MemOrd
    4066. 

  4066. !Local
    4067. 

  4067.   CHARACTER*1                :: c
    4068. 

  4068.   INTEGER       ,PARAMETER   :: upper_to_lower =IACHAR('a')-IACHAR('A')
    4069. 

  4069.   INTEGER                    :: i,n,n1
    4070. 

  4070. !
    4071. 

  4071.   MemOrd = ' '
    4072. 

  4072.   N = len(MemoryOrder)
    4073. 

  4073.   N1 = len(MemOrd)
    4074. 

  4074.   N = MIN(N,N1)
    4075. 

  4075.   MemOrd(1:N) = MemoryOrder(1:N)
    4076. 

  4076.   DO i=1,N
    4077. 

  4077.     c = MemoryOrder(i:i)
    4078. 

  4078.     if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower)
    4079. 

  4079.   ENDDO
    4080. 

  4080.   RETURN
    4081. 

  4081. END SUBROUTINE Lower_Case
    4082. 

  4082. 

  4083. LOGICAL FUNCTION has_char( str, c )
    4084. 

  4084. !<DESCRIPTION>
    4085. 

  4085. !<PRE>
    4086. 

  4086. ! Returns .TRUE. iff string str contains character c.  Ignores character case.  
    4087. 

  4087. !</PRE>
    4088. 

  4088. !</DESCRIPTION>
    4089. 

  4089.   IMPLICIT NONE
    4090. 

  4090.   CHARACTER*(*) str
    4091. 

  4091.   CHARACTER c, d
    4092. 

  4092.   CHARACTER*80 str1, str2, str3
    4093. 

  4093.   INTEGER i
    4094. 

  4094. 

  4095.   CALL lower_case( TRIM(str), str1 )
    4096. 

  4096.   str2 = ""
    4097. 

  4097.   str2(1:1) = c
    4098. 

  4098.   CALL lower_case( str2, str3 )
    4099. 

  4099.   d = str3(1:1)
    4100. 

  4100.   DO i = 1, LEN(TRIM(str1))
    4101. 

  4101.     IF ( str1(i:i) .EQ. d ) THEN
    4102. 

  4102.       has_char = .TRUE.
    4103. 

  4103.       RETURN
    4104. 

  4104.     ENDIF
    4105. 

  4105.   ENDDO
    4106. 

  4106.   has_char = .FALSE.
    4107. 

  4107.   RETURN
    4108. 

  4108. END FUNCTION has_char
    4109. 

  4109. 

  4110.