PageRenderTime 38ms CodeModel.GetById 1ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 3802 lines | 2481 code | 422 blank | 899 comment | 16 complexity | 9b1eb832c545956ed2b6043efc59e2ba MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1. #if (NMM_NEST == 1)
    2. 

  2. !===========================================================================
    3. 

  3. !
    4. 

  4. ! E-GRID NESTING UTILITIES: This is gopal's doing
    5. 

  5. !
    6. 

  6. !===========================================================================
    7. 

  7. 

  8. SUBROUTINE med_nest_egrid_configure ( parent , nest )
    9. 

  9.  USE module_domain
    10. 

  10.  USE module_configure
    11. 

  11.  USE module_timing
    12. 

  12. 

  13.  IMPLICIT NONE
    14. 

  14.  TYPE(domain) , POINTER             :: parent , nest
    15. 

  15.  REAL, PARAMETER                    :: ERAD=6371200.
    16. 

  16.  REAL, PARAMETER                    :: DTR=0.01745329
    17. 

  17.  REAL, PARAMETER                    :: DTAD=1.0
    18. 

  18.  REAL, PARAMETER                    :: CP=1004.6
    19. 

  19.  INTEGER                            :: IDS,IDE,JDS,JDE,KDS,KDE
    20. 

  20.  INTEGER                            :: IMS,IME,JMS,JME,KMS,KME
    21. 

  21.  INTEGER                            :: ITS,ITE,JTS,JTE,KTS,KTE
    22. 

  22.  CHARACTER(LEN=255)                 :: message
    23. 

  23. 

  24. !----------------------------------------------------------------------------
    25. 

  25. !  PURPOSE: 
    26. 

  26. !         - Initialize nested domain configurations including setting up 
    27. 

  27. !           wbd,sbd and some other variables and 1D arrays. 
    28. 

  28. !         - Note that in order to obtain coincident grid points, which  
    29. 

  29. !           is a basic requirement for RSL, WRF infrastructure, we use 
    30. 

  30. !           western and southern boundaries of nested domain (nest%wbd0
    31. 

  31. !           and nest%sbd0 derived from the parent domain. In this case
    32. 

  32. !           the nested domain may be considered as a part of the parent 
    33. 

  33. !           domain with a higher resolution (telescoping ?). 
    34. 

  34. !         - Also note that in this case, the central lat/lons for nested 
    35. 

  35. !           domain should coincide with the central lat/lons of the parent,
    36. 

  36. !           although the nested domain NEED NOT be located at the center of
    37. 

  37. !           the domain.
    38. 

  38. !----------------------------------------------------------------------------
    39. 

  39. !
    40. 

  40. !   BASIC TEST FOR PARENT DOMAIN: CHECK IF JMAX IS ODD. SINCE JDE IN THE NAMELIST
    41. 

  41. !   IS JMAX + 1, WE NEED TO CHECK IF JDE IS EVEN IN WRF CONTEXT
    42. 

  42. 

  43.     IF(MOD(parent%ed32,2) .NE. 0)THEN
    44. 

  44.      CALL wrf_error_fatal("PARENT DOMAIN: JMAX IS EVEN, INCREASE e_sn IN THE namelist.input BY 1")
    45. 

  45.     ENDIF
    46. 

  46. 

  47. !   BASIC TEST FOR NESTED DOMAIN: CHECK IF JMAX IS ODD. SINCE JDE IN THE NAMELIST
    48. 

  48. !   IS JMAX + 1, WE NEED TO CHECK IF JDE IS EVEN IN WRF CONTEXT
    49. 

  49. 

  50.     IF(MOD(nest%ed32,2) .NE. 0)THEN
    51. 

  51.      CALL wrf_error_fatal("NESTED DOMAIN: JMAX IS EVEN, INCREASE e_sn IN THE namelist.input BY 1")
    52. 

  52.     ENDIF
    53. 

  53. 

  54. !   Parent grid configuration, including, western and southern boundary
    55. 

  55. 

  56.     IDS = parent%sd31
    57. 

  57.     IDE = parent%ed31
    58. 

  58.     JDS = parent%sd32
    59. 

  59.     JDE = parent%ed32
    60. 

  60.     KDS = parent%sd33
    61. 

  61.     KDE = parent%ed33
    62. 

  62. 

  63.     IMS = parent%sm31
    64. 

  64.     IME = parent%em31
    65. 

  65.     JMS = parent%sm32
    66. 

  66.     JME = parent%em32
    67. 

  67.     KMS = parent%sm33
    68. 

  68.     KME = parent%em33
    69. 

  69. 

  70.     ITS = parent%sp31
    71. 

  71.     ITE = parent%ep31
    72. 

  72.     JTS = parent%sp32
    73. 

  73.     JTE = parent%ep32
    74. 

  74.     KTS = parent%sp33
    75. 

  75.     KTE = parent%ep33
    76. 

  76. 

  77. !   grid configuration
    78. 

  78. 

  79.     ! calculate wbd0 and sbd0 only for MOAD i.e. grid with parent_id == 0
    80. 

  80.     if (parent%parent_id == 0 ) then        ! Dusan's doing
    81. 

  81.        parent%wbd0 = -(IDE-2)*parent%dx     ! WBD0: in degrees;factor 2 takes care of dummy last column
    82. 

  82.        parent%sbd0 = -((JDE-1)/2)*parent%dy ! SBD0: in degrees; note that JDE-1 should be odd  
    83. 

  83.     end if
    84. 

  84.     nest%wbd0   = parent%wbd0 + (nest%i_parent_start-1)*2.*parent%dx + mod(nest%j_parent_start+1,2)*parent%dx
    85. 

  85.     nest%sbd0   = parent%sbd0 + (nest%j_parent_start-1)*parent%dy
    86. 

  86.     nest%dx     = parent%dx/nest%parent_grid_ratio
    87. 

  87.     nest%dy     = parent%dy/nest%parent_grid_ratio
    88. 

  88. 

  89.     write(message,*)" - i_parent_start = ",nest%i_parent_start
    90. 

  90.     CALL wrf_message(trim(message))
    91. 

  91.     write(message,*)" - j_parent_start = ",nest%j_parent_start
    92. 

  92.     CALL wrf_message(trim(message))
    93. 

  93.     write(message,*)" - parent%wbd0    = ",parent%wbd0
    94. 

  94.     CALL wrf_message(trim(message))
    95. 

  95.     write(message,*)" - parent%sbd0    = ",parent%sbd0
    96. 

  96.     CALL wrf_message(trim(message))
    97. 

  97.     write(message,*)" - nest%wbd0      = ",nest%wbd0
    98. 

  98.     CALL wrf_message(trim(message))
    99. 

  99.     write(message,*)" - nest%sbd0      = ",nest%sbd0
    100. 

  100.     CALL wrf_message(trim(message))
    101. 

  101.     write(message,*)" - nest%dx        = ",nest%dx
    102. 

  102.     CALL wrf_message(trim(message))
    103. 

  103.     write(message,*)" - nest%dy        = ",nest%dy
    104. 

  104.     CALL wrf_message(trim(message))
    105. 

  105. !
    106. 

  106.     CALL nl_set_dx (nest%id , nest%dx)   ! for output purpose
    107. 

  107.     CALL nl_set_dy (nest%id , nest%dy)   ! for output purpose
    108. 

  108. 

  109. !   set lat-lons; parent set to nested domain
    110. 

  110. 

  111.     CALL nl_get_cen_lat (parent%id, parent%cen_lat) ! cen_lat of parent set to nested domain
    112. 

  112.     CALL nl_get_cen_lon (parent%id, parent%cen_lon) ! cen_lon of parent set to nested domain
    113. 

  113. 

  114.     nest%cen_lat=parent%cen_lat
    115. 

  115.     nest%cen_lon=parent%cen_lon
    116. 

  116. !
    117. 

  117.     CALL nl_set_cen_lat ( nest%id , nest%cen_lat)  ! for output purpose
    118. 

  118.     CALL nl_set_cen_lon ( nest%id , nest%cen_lon)  ! for output purpose
    119. 

  119. 

  120.     write(message,*)" - nest%cen_lat   = ",nest%cen_lat
    121. 

  121.     CALL wrf_message(trim(message))
    122. 

  122.     write(message,*)" - nest%cen_lon   = ",nest%cen_lon
    123. 

  123.     CALL wrf_message(trim(message))
    124. 

  124. 

  125. 

  126. !   soil configuration
    127. 

  127. 

  128. #ifdef HWRF
    129. 

  129. !zhang 
    130. 

  130.     if ( .not.nest%analysis ) then
    131. 

  131. #endif
    132. 

  132.     nest%sldpth  = parent%sldpth
    133. 

  133.     nest%dzsoil  = parent%dzsoil
    134. 

  134.     nest%rtdpth  = parent%rtdpth
    135. 

  135. #ifdef HWRF 
    136. 

  136.     endif
    137. 

  137. #endif
    138. 

  138. 

  139. !   numerical set up
    140. 

  140. 

  141.     nest%deta        = parent%deta
    142. 

  142.     nest%aeta        = parent%aeta
    143. 

  143.     nest%etax        = parent%etax
    144. 

  144.     nest%dfl         = parent%dfl
    145. 

  145.     nest%deta1       = parent%deta1
    146. 

  146.     nest%aeta1       = parent%aeta1
    147. 

  147.     nest%eta1        = parent%eta1
    148. 

  148.     nest%deta2       = parent%deta2
    149. 

  149.     nest%aeta2       = parent%aeta2
    150. 

  150.     nest%eta2        = parent%eta2
    151. 

  151.     nest%pdtop       = parent%pdtop
    152. 

  152.     nest%pt          = parent%pt
    153. 

  153.     nest%dfrlg       = parent%dfrlg
    154. 

  154.     nest%num_soil_layers = parent%num_soil_layers
    155. 

  155.     nest%num_moves       = parent%num_moves
    156. 

  156. 

  157. ! Unfortunately, some of the single value constants in used in module_initialize have 
    158. 

  158. ! to be defiend here instead of the usual spot in med_initialize_nest_nmm. There
    159. 

  159. ! appears to be a problem in Registry and related code in this area.
    160. 

  160. !
    161. 

  161. ! state  logical upstrm   -      dyn_nmm     -      -      -
    162. 

  162. 

  163. 

  164.     nest%dlmd   = nest%dx
    165. 

  165.     nest%dphd   = nest%dy
    166. 

  166.     nest%dy_nmm = erad*(nest%dphd*dtr)
    167. 

  167.     nest%cpgfv  = -nest%dt/(48.*nest%dy_nmm)
    168. 

  168.     nest%en     = nest%dt/( 4.*nest%dy_nmm)*dtad
    169. 

  169.     nest%ent    = nest%dt/(16.*nest%dy_nmm)*dtad
    170. 

  170.     nest%f4d    = -.5*nest%dt*dtad
    171. 

  171.     nest%f4q    = -nest%dt*dtad
    172. 

  172.     nest%ef4t   = .5*nest%dt/cp
    173. 

  173. 

  174. !  Other output configurations that will make grads happy 
    175. 

  175. 

  176.    CALL nl_get_truelat1 (parent%id, parent%truelat1 )
    177. 

  177.    CALL nl_get_truelat2 (parent%id, parent%truelat2 )
    178. 

  178. #ifdef HWRF
    179. 

  179. ! bao : to make the restart output identical at the restart initial time for stand_lon
    180. 

  180.    CALL nl_get_stand_lon (parent%id, parent%stand_lon )
    181. 

  181. #endif
    182. 

  182.    CALL nl_get_map_proj (parent%id, parent%map_proj )
    183. 

  183.    CALL nl_get_iswater (parent%id, parent%iswater )
    184. 

  184. 

  185.    nest%truelat1=parent%truelat1
    186. 

  186.    nest%truelat2=parent%truelat2
    187. 

  187. !bao
    188. 

  188.    nest%stand_lon=parent%stand_lon
    189. 

  189. !bao
    190. 

  190.    nest%map_proj=parent%map_proj
    191. 

  191.    nest%iswater=parent%iswater
    192. 

  192. 

  193.    CALL nl_set_truelat1(nest%id, nest%truelat1)
    194. 

  194.    CALL nl_set_truelat2(nest%id, nest%truelat2)
    195. 

  195. !bao
    196. 

  196.    CALL nl_set_stand_lon(nest%id, nest%stand_lon)
    197. 

  197. !bao
    198. 

  198.    CALL nl_set_map_proj(nest%id, nest%map_proj)
    199. 

  199.    CALL nl_set_iswater(nest%id, nest%iswater)
    200. 

  200. 

  201. !   physics and other configurations
    202. 

  202. !   CALL nl_get_iswater (parent%id, nest%iswater) ! iswater is just based on parents
    203. 

  203. !   CALL nl_get_bl_surface_physics (nest%id,  nest%bl_surface_physics )
    204. 

  204. !   CALL nl_get_num_soil_layers( parent%num_soil_layers )
    205. 

  205. !   CALL nl_get_real_data_init_type (parent%real_data_init_type)
    206. 

  206. 

  207. END SUBROUTINE med_nest_egrid_configure
    208. 

  208. 

  209. SUBROUTINE med_construct_egrid_weights ( parent , nest )
    210. 

  210.  USE module_domain
    211. 

  211.  USE module_configure
    212. 

  212.  USE module_timing
    213. 

  213. 

  214.  IMPLICIT NONE
    215. 

  215.  TYPE(domain) , POINTER             :: parent , nest
    216. 

  216.  LOGICAL, EXTERNAL                  :: wrf_dm_on_monitor
    217. 

  217.  INTEGER                            :: IDS,IDE,JDS,JDE,KDS,KDE
    218. 

  218.  INTEGER                            :: IMS,IME,JMS,JME,KMS,KME
    219. 

  219.  INTEGER                            :: ITS,ITE,JTS,JTE,KTS,KTE
    220. 

  220.  INTEGER                            :: I,J,II,JJ,NII,NJJ
    221. 

  221.  REAL                               :: parent_CLAT,parent_CLON,parent_WBD,parent_SBD,parent_DLMD,parent_DPHD
    222. 

  222.  REAL                               :: nest_WBD,nest_SBD,nest_DLMD,nest_DPHD
    223. 

  223.  REAL                               :: SW_LATD,SW_LOND
    224. 

  224.  REAL                               :: ADDSUM1,ADDSUM2
    225. 

  225.  REAL                               :: xr,zr,xc
    226. 

  226. !-----------------------------------------------------------------------------------------------------------
    227. 

  227. !   PURPOSE: 
    228. 

  228. !           - Initialize lat-lons and determine weights 
    229. 

  229. !
    230. 

  230. !----------------------------------------------------------------------------------------------------------
    231. 

  231. 

  232. !   First obtain central latitude and longitude for the parent domain
    233. 

  233. 

  234.     CALL nl_get_cen_lat (parent%ID, parent_CLAT)
    235. 

  235.     CALL nl_get_cen_lon (parent%ID, parent_CLON)
    236. 

  236. 

  237. !   Parent grid configuration, including, western and southern boundary
    238. 

  238. 

  239.     IDS = parent%sd31
    240. 

  240.     IDE = parent%ed31
    241. 

  241.     JDS = parent%sd32
    242. 

  242.     JDE = parent%ed32
    243. 

  243.     KDS = parent%sd33
    244. 

  244.     KDE = parent%ed33
    245. 

  245. 

  246.     IMS = parent%sm31
    247. 

  247.     IME = parent%em31
    248. 

  248.     JMS = parent%sm32
    249. 

  249.     JME = parent%em32
    250. 

  250.     KMS = parent%sm33
    251. 

  251.     KME = parent%em33
    252. 

  252. 

  253.     ITS  = parent%sp31
    254. 

  254.     ITE  = parent%ep31
    255. 

  255.     JTS  = parent%sp32
    256. 

  256.     JTE  = parent%ep32
    257. 

  257.     KTS  = parent%sp33
    258. 

  258.     KTE  = parent%ep33
    259. 

  259. !
    260. 

  260.     parent_DLMD = parent%dx                ! DLMD: dlamda in degrees 
    261. 

  261.     parent_DPHD = parent%dy                ! DPHD: dphi in degrees 
    262. 

  262.     parent_WBD  = parent%wbd0
    263. 

  263.     parent_SBD  = parent%sbd0
    264. 

  264. 

  265. !   Now compute Geodetic lat/lon (Positive East) of parent grid in degrees
    266. 

  266. 

  267.     CALL EARTH_LATLON ( parent%HLAT,parent%HLON,parent%VLAT,parent%VLON,  & !output
    268. 

  268.                         parent_DLMD,parent_DPHD,parent_WBD,parent_SBD,                    & !inputs 
    269. 

  269.                         parent_CLAT,parent_CLON,                                          &
    270. 

  270.                         IDS,IDE,JDS,JDE,KDS,KDE,                                          &
    271. 

  271.                         IMS,IME,JMS,JME,KMS,KME,                                          &
    272. 

  272.                         ITS,ITE,JTS,JTE,KTS,KTE                                           )
    273. 

  273. 

  274. !   Nested grid configuration, including, western and southern boundary
    275. 

  275. 

  276.     IDS = nest%sd31
    277. 

  277.     IDE = nest%ed31
    278. 

  278.     JDS = nest%sd32
    279. 

  279.     JDE = nest%ed32
    280. 

  280.     KDS = nest%sd33
    281. 

  281.     KDE = nest%ed33
    282. 

  282. 

  283.     IMS = nest%sm31
    284. 

  284.     IME = nest%em31
    285. 

  285.     JMS = nest%sm32
    286. 

  286.     JME = nest%em32
    287. 

  287.     KMS = nest%sm33
    288. 

  288.     KME = nest%em33
    289. 

  289. 

  290.     ITS  = nest%sp31
    291. 

  291.     ITE  = nest%ep31
    292. 

  292.     JTS  = nest%sp32
    293. 

  293.     JTE  = nest%ep32
    294. 

  294.     KTS  = nest%sp33
    295. 

  295.     KTE  = nest%ep33
    296. 

  296. !
    297. 

  297.     nest_DLMD = nest%dx
    298. 

  298.     nest_DPHD = nest%dy
    299. 

  299.     nest_WBD  = nest%wbd0
    300. 

  300.     nest_SBD  = nest%sbd0
    301. 

  301. 

  302. !
    303. 

  303. !   Now compute Geodetic lat/lon (Positive East) of nest in degrees, with the same central lat-lon
    304. 

  304. !   as the parent grid
    305. 

  305. !
    306. 

  306. 

  307.     CALL EARTH_LATLON ( nest%HLAT,nest%HLON,nest%VLAT,nest%VLON, & ! output
    308. 

  308.                         nest_DLMD,nest_DPHD,nest_WBD,nest_SBD,                   & ! nest inputs
    309. 

  309.                         parent_CLAT,parent_CLON,                                 & ! parent central lat/lon
    310. 

  310.                         IDS,IDE,JDS,JDE,KDS,KDE,                                 & ! nested domain dimension
    311. 

  311.                         IMS,IME,JMS,JME,KMS,KME,                                 &
    312. 

  312.                         ITS,ITE,JTS,JTE,KTS,KTE                                  )
    313. 

  313. 

  314. !   Determine the weights of nested grid h points nearest to H points of parent domain 
    315. 

  315. 

  316.   if(nest%vortex_tracker /= 1) then
    317. 

  317.     CALL G2T2H_new(    nest%IIH,nest%JJH,                            & ! output grid index in parent grid
    318. 

  318.                        nest%HBWGT1,nest%HBWGT2,                      & ! output weights in terms of parent grid
    319. 

  319.                        nest%HBWGT3,nest%HBWGT4,                      &
    320. 

  320.                        nest%I_PARENT_START,nest%J_PARENT_START,      & ! nest start I, J in parent domain
    321. 

  321.                        3,                              & ! Ratio of parent and child grid ( always = 3 for NMM)
    322. 

  322.                        IDS,IDE,JDS,JDE,KDS,KDE,            & ! target (nest) dimensions
    323. 

  323.                        IMS,IME,JMS,JME,KMS,KME,            &
    324. 

  324.                        ITS,ITE,JTS,JTE,KTS,KTE      )
    325. 

  325.   else
    326. 

  326.     CALL G2T2H( nest%IIH,nest%JJH,                       & ! output grid index on nested grid
    327. 

  327.                 nest%HBWGT1,nest%HBWGT2,                 & ! output weights on the nested grid 
    328. 

  328.                 nest%HBWGT3,nest%HBWGT4,                 &
    329. 

  329.                 nest%HLAT,nest%HLON,                     & ! target (nest) input lat lon in degrees
    330. 

  330.                 parent_DLMD,parent_DPHD,parent_WBD,parent_SBD,   & ! parent res, western and south boundaries
    331. 

  331.                 parent_CLAT,parent_CLON,                         & ! parent central lat,lon, all in degrees
    332. 

  332.                 parent%ed31,parent%ed32,                         & ! parent imax and jmax
    333. 

  333.                 IDS,IDE,JDS,JDE,KDS,KDE,                         & ! 
    334. 

  334.                 IMS,IME,JMS,JME,KMS,KME,                         & ! nested grid configuration
    335. 

  335.                 ITS,ITE,JTS,JTE,KTS,KTE                          ) !
    336. 

  336.   endif
    337. 

  337. 

  338. 

  339. !   Determine the weights of nested grid v points nearest to V points of parent domain
    340. 

  340. 

  341.   if(nest%vortex_tracker /= 1) then
    342. 

  342.     CALL G2T2V_new(    nest%IIV,nest%JJV,                            & ! output grid index in parent grid
    343. 

  343.                        nest%VBWGT1,nest%VBWGT2,                      & ! output weights in terms of parent grid
    344. 

  344.                        nest%VBWGT3,nest%VBWGT4,                      &
    345. 

  345.                        nest%I_PARENT_START,nest%J_PARENT_START,      & ! nest start I, J in parent domain
    346. 

  346.                        3,                              & ! Ratio of parent and child grid ( always = 3 for NMM)
    347. 

  347.                        IDS,IDE,JDS,JDE,KDS,KDE,            & ! target (nest) dimensions
    348. 

  348.                        IMS,IME,JMS,JME,KMS,KME,            &
    349. 

  349.                        ITS,ITE,JTS,JTE,KTS,KTE      )
    350. 

  350.   else
    351. 

  351.     CALL G2T2V( nest%IIV,nest%JJV,                       & ! output grid index on nested grid
    352. 

  352.                 nest%VBWGT1,nest%VBWGT2,                 & ! output weights on the nested grid
    353. 

  353.                 nest%VBWGT3,nest%VBWGT4,                 &
    354. 

  354.                 nest%VLAT,nest%VLON,                     & ! target (nest) input lat lon in degrees
    355. 

  355.                 parent_DLMD,parent_DPHD,parent_WBD,parent_SBD,   & ! parent res, western and south boundaries
    356. 

  356.                 parent_CLAT,parent_CLON,                         & ! parent central lat,lon, all in degrees
    357. 

  357.                 parent%ed31,parent%ed32,                         & ! parent imax and jmax
    358. 

  358.                 IDS,IDE,JDS,JDE,KDS,KDE,                         & !
    359. 

  359.                 IMS,IME,JMS,JME,KMS,KME,                         & ! nested grid configuration
    360. 

  360.                 ITS,ITE,JTS,JTE,KTS,KTE                          ) !
    361. 

  361.   endif
    362. 

  362. 

  363. !*** CHECK WEIGHTS AT MASS AND VELOCITY POINTS
    364. 

  364. 

  365.      CALL WEIGTS_CHECK(nest%HBWGT1,nest%HBWGT2,          & ! output weights on the nested grid
    366. 

  366.                        nest%HBWGT3,nest%HBWGT4,          &
    367. 

  367.                        nest%VBWGT1,nest%VBWGT2,          & ! output weights on the nested grid
    368. 

  368.                        nest%VBWGT3,nest%VBWGT4,          &
    369. 

  369.                        IDS,IDE,JDS,JDE,KDS,KDE,                  & !
    370. 

  370.                        IMS,IME,JMS,JME,KMS,KME,                  & ! nested grid configuration
    371. 

  371.                        ITS,ITE,JTS,JTE,KTS,KTE                   )
    372. 

  372. 

  373. !*** CHECK DOMAIN BOUNDS BEFORE PROCEEDING TO INTERPOLATION
    374. 

  374. !
    375. 

  375.     CALL BOUNDS_CHECK( nest%IIH,nest%JJH,nest%IIV,nest%JJV,   &
    376. 

  376.                        nest%i_parent_start,nest%j_parent_start,nest%shw,      &
    377. 

  377.                        IDS,IDE,JDS,JDE,KDS,KDE,                               & !
    378. 

  378.                        IMS,IME,JMS,JME,KMS,KME,                               & ! nested grid configuration
    379. 

  379.                        ITS,ITE,JTS,JTE,KTS,KTE                                )
    380. 

  380. 

  381. !------------------------------------------------------------------------------------------
    382. 

  382. 

  383. END SUBROUTINE med_construct_egrid_weights 
    384. 

  384. 

  385. !======================================================================================
    386. 

  386. !
    387. 

  387. ! compute earth lat-lons for parent and the nest before interpolations
    388. 

  388. !------------------------------------------------------------------------------
    389. 

  389. 

  390. SUBROUTINE EARTH_LATLON ( HLAT,HLON,VLAT,VLON,     & !Earth lat,lon at H and V points
    391. 

  391.                           DLMD1,DPHD1,WBD1,SBD1,   & !input res,west & south boundaries,
    392. 

  392.                           CENTRAL_LAT,CENTRAL_LON, & ! central lat,lon, all in degrees   
    393. 

  393.                           IDS,IDE,JDS,JDE,KDS,KDE, &  
    394. 

  394.                           IMS,IME,JMS,JME,KMS,KME, &
    395. 

  395.                           ITS,ITE,JTS,JTE,KTS,KTE  )
    396. 

  396. !============================================================================
    397. 

  397. !
    398. 

  398.  IMPLICIT NONE
    399. 

  399.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    400. 

  400.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME 
    401. 

  401.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE  
    402. 

  402.  REAL,       INTENT(IN   )                            :: DLMD1,DPHD1,WBD1,SBD1
    403. 

  403.  REAL,       INTENT(IN   )                            :: CENTRAL_LAT,CENTRAL_LON
    404. 

  404.  REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT)        :: HLAT,HLON,VLAT,VLON
    405. 

  405. 

  406. ! local
    407. 

  407. 

  408.  INTEGER,PARAMETER                           :: KNUM=SELECTED_REAL_KIND(13) 
    409. 

  409.  INTEGER                                     :: I,J
    410. 

  410.  REAL(KIND=KNUM)                             :: WB,SB,DLM,DPH,TPH0,STPH0,CTPH0
    411. 

  411.  REAL(KIND=KNUM)                             :: TDLM,TDPH,TLMH,TLMV,TLMH0,TLMV0,TPHH,TPHV,DTR
    412. 

  412.  REAL(KIND=KNUM)                             :: STPH,CTPH,STPV,CTPV,PI_2
    413. 

  413.  REAL(KIND=KNUM)                             :: SPHH,CLMH,FACTH,SPHV,CLMV,FACTV
    414. 

  414.  REAL(KIND=KNUM), DIMENSION(IMS:IME,JMS:JME) :: GLATH,GLONH,GLATV,GLONV
    415. 

  415. !-------------------------------------------------------------------------
    416. 

  416. 

  417. !
    418. 

  418.       PI_2 = ACOS(0.)
    419. 

  419.       DTR  = PI_2/90.
    420. 

  420.       WB   = WBD1 * DTR                 ! WB:   western boundary in radians
    421. 

  421.       SB   = SBD1 * DTR                 ! SB:   southern boundary in radians
    422. 

  422.       DLM  = DLMD1 * DTR                ! DLM:  dlamda in radians 
    423. 

  423.       DPH  = DPHD1 * DTR                ! DPH:  dphi   in radians
    424. 

  424.       TDLM = DLM + DLM                  ! TDLM: 2.0*dlamda 
    425. 

  425.       TDPH = DPH + DPH                  ! TDPH: 2.0*DPH 
    426. 

  426. 

  427. !     For earth lat lon only
    428. 

  428. 

  429.       TPH0  = CENTRAL_LAT*DTR                ! TPH0: central lat in radians 
    430. 

  430.       STPH0 = SIN(TPH0)
    431. 

  431.       CTPH0 = COS(TPH0)
    432. 

  432. 

  433.                                                 !    .H
    434. 

  434.       DO J = JTS,MIN(JTE,JDE-1)                 ! H./    This loop takes care of zig-zag 
    435. 

  435. !                                               !   \.H  starting points along j  
    436. 

  436.          TLMH0 = WB - TDLM + MOD(J+1,2) * DLM   !  ./    TLMH (rotated lats at H points)
    437. 

  437.          TLMV0 = WB - TDLM + MOD(J,2) * DLM     !  H     (//ly for V points) 
    438. 

  438.          TPHH = SB + (J-1)*DPH                  !   TPHH (rotated lons at H points) are simple trans.
    439. 

  439.          TPHV = TPHH                            !   TPHV (rotated lons at V points) are simple trans.
    440. 

  440.          STPH = SIN(TPHH)
    441. 

  441.          CTPH = COS(TPHH)
    442. 

  442.          STPV = SIN(TPHV)
    443. 

  443.          CTPV = COS(TPHV)
    444. 

  444. 

  445.                                                               !   .H
    446. 

  446.          DO I = ITS,MIN(ITE,IDE-1)                            !  / 
    447. 

  447.            TLMH = TLMH0 + I*TDLM                              !  \.H   .U   .H 
    448. 

  448. !                                                             !H./ ----><----
    449. 

  449.            SPHH = CTPH0 * STPH + STPH0 * CTPH * COS(TLMH)     !     DLM + DLM
    450. 

  450.            GLATH(I,J)=ASIN(SPHH)                              ! GLATH: Earth Lat in radians 
    451. 

  451.            CLMH = CTPH*COS(TLMH)/(COS(GLATH(I,J))*CTPH0) &
    452. 

  452.                 - TAN(GLATH(I,J))*TAN(TPH0)
    453. 

  453.            IF(CLMH .GT. 1.) CLMH = 1.0
    454. 

  454.            IF(CLMH .LT. -1.) CLMH = -1.0
    455. 

  455.            FACTH = 1.
    456. 

  456.            IF(TLMH .GT. 0.) FACTH = -1.
    457. 

  457.            GLONH(I,J) = -CENTRAL_LON*DTR + FACTH*ACOS(CLMH)
    458. 

  458. 

  459.          ENDDO                                    
    460. 

  460. 

  461.          DO I = ITS,MIN(ITE,IDE-1)
    462. 

  462.            TLMV = TLMV0 + I*TDLM
    463. 

  463.            SPHV = CTPH0 * STPV + STPH0 * CTPV * COS(TLMV)
    464. 

  464.            GLATV(I,J) = ASIN(SPHV)
    465. 

  465.            CLMV = CTPV*COS(TLMV)/(COS(GLATV(I,J))*CTPH0) &
    466. 

  466.                 - TAN(GLATV(I,J))*TAN(TPH0)
    467. 

  467.            IF(CLMV .GT. 1.) CLMV = 1.
    468. 

  468.            IF(CLMV .LT. -1.) CLMV = -1.
    469. 

  469.            FACTV = 1.
    470. 

  470.            IF(TLMV .GT. 0.) FACTV = -1.
    471. 

  471.            GLONV(I,J) = -CENTRAL_LON*DTR + FACTV*ACOS(CLMV)
    472. 

  472. 

  473.          ENDDO
    474. 

  474. 

  475.       ENDDO
    476. 

  476. 

  477. !     Conversion to degrees (may not be required, eventually)
    478. 

  478. 

  479.       DO J = JTS, MIN(JTE,JDE-1)
    480. 

  480.        DO I = ITS, MIN(ITE,IDE-1)
    481. 

  481.           HLAT(I,J) = GLATH(I,J) / DTR
    482. 

  482.           HLON(I,J)= -GLONH(I,J)/DTR
    483. 

  483.           IF(HLON(I,J) .GT. 180.) HLON(I,J) = HLON(I,J)  - 360.
    484. 

  484.           IF(HLON(I,J) .LT. -180.) HLON(I,J) = HLON(I,J) + 360.
    485. 

  485. !
    486. 

  486.           VLAT(I,J) = GLATV(I,J) / DTR
    487. 

  487.           VLON(I,J) = -GLONV(I,J) / DTR
    488. 

  488.           IF(VLON(I,J) .GT. 180.) VLON(I,J) = VLON(I,J)  - 360.
    489. 

  489.           IF(VLON(I,J) .LT. -180.) VLON(I,J) = VLON(I,J) + 360.
    490. 

  490. 

  491.        ENDDO
    492. 

  492.       ENDDO
    493. 

  493. 

  494. END SUBROUTINE EARTH_LATLON
    495. 

  495. 

  496. !-----------------------------------------------------------------------------  
    497. 

  497. 

  498.   SUBROUTINE G2T2H( IIH,JJH,                     & ! output grid index and weights 
    499. 

  499.                     HBWGT1,HBWGT2,               & ! output weights in terms of parent grid
    500. 

  500.                     HBWGT3,HBWGT4,               & 
    501. 

  501.                     HLAT,HLON,                   & ! target (nest) input lat lon in degrees
    502. 

  502.                     DLMD1,DPHD1,WBD1,SBD1,       & ! parent res, west and south boundaries
    503. 

  503.                     CENTRAL_LAT,CENTRAL_LON,     & ! parent central lat,lon, all in degrees
    504. 

  504.                     P_IDE,P_JDE,                 & ! parent imax and jmax
    505. 

  505.                     IDS,IDE,JDS,JDE,KDS,KDE,     & ! target (nest) dIMEnsions
    506. 

  506.                     IMS,IME,JMS,JME,KMS,KME,     &
    507. 

  507.                     ITS,ITE,JTS,JTE,KTS,KTE      )
    508. 

  508. 

  509. ! 
    510. 

  510. !***  Tom Black   - Initial Version
    511. 

  511. !***  Gopal       - Revised Version for WRF (includes coincident grid points) 
    512. 

  512. !*** 
    513. 

  513. !***  GIVEN PARENT CENTRAL LAT-LONS, RESOLUTION AND WESTERN AND SOUTHERN BOUNDARY,
    514. 

  514. !***  AND THE NESTED GRID LAT-LONS AT H POINTS, THIS ROUTINE FIRST LOCATES THE 
    515. 

  515. !***  INDICES,IIH,JJH, OF THE PARENT DOMAIN'S H POINTS THAT LIES CLOSEST TO THE
    516. 

  516. !***  h POINTS OF THE NESTED DOMAIN   
    517. 

  517. !
    518. 

  518. !============================================================================
    519. 

  519. !
    520. 

  520.  IMPLICIT NONE
    521. 

  521.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    522. 

  522.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    523. 

  523.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    524. 

  524.  INTEGER,    INTENT(IN   )                            :: P_IDE,P_JDE
    525. 

  525.  REAL,       INTENT(IN   )                            :: DLMD1,DPHD1,WBD1,SBD1
    526. 

  526.  REAL,       INTENT(IN   )                            :: CENTRAL_LAT,CENTRAL_LON
    527. 

  527.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(IN)   :: HLAT,HLON
    528. 

  528.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    529. 

  529.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
    530. 

  530. 

  531. ! local
    532. 

  532. 

  533.  INTEGER,PARAMETER :: KNUM=SELECTED_REAL_KIND(13)
    534. 

  534.  INTEGER           :: IMT,JMT,N2R,MK,K,I,J,DSLP0,DSLOPE
    535. 

  535.  INTEGER           :: NROW,NCOL,KROWS
    536. 

  536.  REAL(KIND=KNUM)   :: X,Y,Z,TLAT,TLON
    537. 

  537.  REAL(KIND=KNUM)   :: PI_2,D2R,R2D,GLAT,GLON,DPH,DLM,TPH0,TLM0,WB,SB                
    538. 

  538.  REAL(KIND=KNUM)   :: ROW,COL,SLP0,TLATHC,TLONHC,DENOM,SLOPE
    539. 

  539.  REAL(KIND=KNUM)   :: TLAT1,TLAT2,TLON1,TLON2,DLM1,DLM2,DLM3,DLM4,D1,D2
    540. 

  540.  REAL(KIND=KNUM)   :: DLA1,DLA2,DLA3,DLA4,S1,R1,DS1,AN1,AN2,AN3                    ! Q
    541. 

  541.  REAL(KIND=KNUM)   :: DL1,DL2,DL3,DL4,DL1I,DL2I,DL3I,DL4I,SUMDL,TLONO,TLATO 
    542. 

  542.  REAL(KIND=KNUM)   :: DTEMP
    543. 

  543.  REAL   , DIMENSION(IMS:IME,JMS:JME)    :: TLATHX,TLONHX
    544. 

  544.  INTEGER, DIMENSION(IMS:IME,JMS:JME)    :: KOUTB
    545. 

  545. !------------------------------------------------------------------------------- 
    546. 

  546. 

  547.   IMT=2*P_IDE-2             ! parent i dIMEnsions 
    548. 

  548.   JMT=P_JDE/2               ! parent j dIMEnsions 
    549. 

  549.   PI_2=ACOS(0.)
    550. 

  550.   D2R=PI_2/90.
    551. 

  551.   R2D=1./D2R
    552. 

  552.   DPH=DPHD1*D2R
    553. 

  553.   DLM=DLMD1*D2R
    554. 

  554.   TPH0= CENTRAL_LAT*D2R
    555. 

  555.   TLM0=-CENTRAL_LON*D2R        ! NOTE THE MINUS HERE
    556. 

  556.   WB=WBD1*D2R                   ! CONVERT NESTED GRID H POINTS FROM GEODETIC
    557. 

  557.   SB=SBD1*D2R
    558. 

  558.   SLP0=DPHD1/DLMD1
    559. 

  559.   DSLP0=NINT(R2D*ATAN(SLP0))
    560. 

  560.   DS1=SQRT(DPH*DPH+DLM*DLM)    ! Q
    561. 

  561.   AN1=ASIN(DLM/DS1)
    562. 

  562.   AN2=ASIN(DPH/DS1)
    563. 

  563. 

  564.   DO J =  JTS,MIN(JTE,JDE-1) 
    565. 

  565.     DO I = ITS,MIN(ITE,IDE-1) 
    566. 

  566. 

  567. !***
    568. 

  568. !***  LOCATE TARGET h POINTS (HLAT AND HLON) ON THE PARENT DOMAIN AND
    569. 

  569. !***  DETERMINE THE INDICES IN TERMS OF THE PARENT DOMAIN. FIRST 
    570. 

  570. !***  CONVERT NESTED GRID h POINTS FROM GEODETIC TO TRANSFORMED 
    571. 

  571. !***  COORDINATE ON THE PARENT GRID
    572. 

  572. !
    573. 

  573. 

  574.       GLAT=HLAT(I,J)*D2R
    575. 

  575.       GLON= (360. - HLON(I,J))*D2R
    576. 

  576.       X=COS(TPH0)*COS(GLAT)*COS(GLON-TLM0)+SIN(TPH0)*SIN(GLAT)
    577. 

  577.       Y=-COS(GLAT)*SIN(GLON-TLM0)
    578. 

  578.       Z=COS(TPH0)*SIN(GLAT)-SIN(TPH0)*COS(GLAT)*COS(GLON-TLM0)
    579. 

  579.       TLAT=R2D*ATAN(Z/SQRT(X*X+Y*Y))
    580. 

  580.       TLON=R2D*ATAN(Y/X)
    581. 

  581. 

  582. !      ROW=TLAT/DPHD1+JMT         ! JMT IS THE CENTRAL ROW OF THE PARENT DOMAIN
    583. 

  583. !      COL=TLON/DLMD1+P_IDE-1     ! (P_IDE-1) IS THE CENTRAL COLUMN OF THE PARENT DOMAIN 
    584. 

  584. 

  585.       ROW=(TLAT-SBD1)/DPHD1+1     ! Dusan's doing
    586. 

  586.       COL=(TLON-WBD1)/DLMD1+1     ! Dusan's doing
    587. 

    588. 

  588.       NROW=INT(ROW + 0.001)     ! ROUND-OFF IS AVOIDED WITHOUT USING NINT ON PURPOSE
    589. 

  589.       NCOL=INT(COL + 0.001)     
    590. 

  590.       TLAT=TLAT*D2R
    591. 

  591.       TLON=TLON*D2R
    592. 

  592. 

  593. !***  
    594. 

  594. !***
    595. 

  595. !***  FIRST CONSIDER THE SITUATION WHERE THE POINT h IS AT
    596. 

  596. !***
    597. 

  597. !***              V      H
    598. 

  598. !***
    599. 

  599. !***
    600. 

  600. !***                 H           
    601. 

  601. !***              H      V
    602. 

  602. !***
    603. 

  603. !***  THEN LOCATE THE NEAREST H POINT ON THE PARENT GRID
    604. 

  604. !***
    605. 

  605.       IF(MOD(NROW,2).EQ.1.AND.MOD(NCOL,2).EQ.1.OR.     &     
    606. 

  606.          MOD(NROW,2).EQ.0.AND.MOD(NCOL,2).EQ.0)THEN        
    607. 

  607.            TLAT1=(NROW-JMT)*DPH                           
    608. 

  608.            TLAT2=TLAT1+DPH                              
    609. 

  609.            TLON1=(NCOL-(P_IDE-1))*DLM                                   
    610. 

  610.            TLON2=TLON1+DLM                                 
    611. 

  611.            DLM1=TLON-TLON1                                 
    612. 

  612.            DLM2=TLON-TLON2
    613. 

  613. !           D1=ACOS(COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
    614. 

  614. !           D2=ACOS(COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
    615. 

  615.            DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
    616. 

  616.            D1=ACOS(DTEMP)
    617. 

  617.            DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
    618. 

  618.            D2=ACOS(DTEMP)
    619. 

  619.             IF(D1.GT.D2)THEN
    620. 

  620.              NROW=NROW+1                    ! FIND THE NEAREST H ROW
    621. 

  621.              NCOL=NCOL+1                    ! FIND THE NEAREST H COLUMN
    622. 

  622.             ENDIF 
    623. 

  623.       ELSE
    624. 

  624. !***
    625. 

  625. !***  NOW CONSIDER THE SITUATION WHERE THE POINT h IS AT
    626. 

  626. !***
    627. 

  627. !***              H      V
    628. 

  628. !***
    629. 

  629. !***
    630. 

  630. !***                 H 
    631. 

  631. !***              V      H
    632. 

  632. !***
    633. 

  633. !***  THEN LOCATE THE NEAREST H POINT ON THE PARENT GRID
    634. 

  634. !***
    635. 

  635. !***
    636. 

  636.            TLAT1=(NROW+1-JMT)*DPH
    637. 

  637.            TLAT2=TLAT1-DPH
    638. 

  638.            TLON1=(NCOL-(P_IDE-1))*DLM
    639. 

  639.            TLON2=TLON1+DLM
    640. 

  640.            DLM1=TLON-TLON1
    641. 

  641.            DLM2=TLON-TLON2
    642. 

  642. !           D1=ACOS(COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
    643. 

  643. !           D2=ACOS(COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
    644. 

  644.            DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
    645. 

  645.            D1=ACOS(DTEMP)
    646. 

  646.            DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
    647. 

  647.            D2=ACOS(DTEMP)
    648. 

  648.              IF(D1.LT.D2)THEN
    649. 

  649.               NROW=NROW+1                    ! FIND THE NEAREST H ROW
    650. 

  650.              ELSE
    651. 

  651.               NCOL=NCOL+1                    ! FIND THE NEAREST H COLUMN
    652. 

  652.              ENDIF
    653. 

  653.       ENDIF
    654. 

  654. 

  655.       KROWS=((NROW-1)/2)*IMT
    656. 

  656.       IF(MOD(NROW,2).EQ.1)THEN
    657. 

  657.         K=KROWS+(NCOL+1)/2
    658. 

  658.       ELSE
    659. 

  659.         K=KROWS+P_IDE-1+NCOL/2
    660. 

  660.       ENDIF
    661. 

  661. 

  662. !***
    663. 

  663. !***  WE NOW KNOW THAT THE INNER GRID POINT IN QUESTION IS
    664. 

  664. !***  NEAREST TO THE CENTER K AS SEEN BELOW.  WE MUST FIND
    665. 

  665. !***  WHICH OF THE FOUR H-BOXES (OF WHICH THIS H POINT IS
    666. 

  666. !***  A VERTEX) SURROUNDS THE INNER GRID h POINT IN QUESTION.
    667. 

  667. !***
    668. 

  668. !**
    669. 

  669. !***                  H
    670. 

  670. !***
    671. 

  671. !***
    672. 

  672. !***
    673. 

  673. !***            H     V     H
    674. 

  674. !***
    675. 

  675. !***
    676. 

  676. !***               H
    677. 

  677. !***      H     V     H     V     H
    678. 

  678. !***
    679. 

  679. !***
    680. 

  680. !***
    681. 

  681. !***            H     V     H
    682. 

  682. !***
    683. 

  683. !***
    684. 

  684. !***
    685. 

  685. !***                  H
    686. 

  686. !***
    687. 

  687. !***
    688. 

  688. !***  FIND THE SLOPE OF THE LINE CONNECTING h AND THE CENTER H.
    689. 

  689. !***
    690. 

  690.     N2R=K/IMT
    691. 

  691.     MK=MOD(K,IMT)
    692. 

  692. !
    693. 

  693.     IF(MK.EQ.0)THEN
    694. 

  694.       TLATHC=SB+(2*N2R-1)*DPH
    695. 

  695.     ELSE
    696. 

  696.       TLATHC=SB+(2*N2R+(MK-1)/(P_IDE-1))*DPH
    697. 

  697.     ENDIF
    698. 

  698. !
    699. 

  699.     IF(MK.LE.(P_IDE-1))THEN
    700. 

  700.       TLONHC=WB+2*(MK-1)*DLM
    701. 

  701.     ELSE
    702. 

  702.       TLONHC=WB+(2*(MK-(P_IDE-1))-1)*DLM
    703. 

  703.     ENDIF
    704. 

  704.   
    705. 

  705. !
    706. 

  706. !***  EXECUTE CAUTION IF YOU NEED TO CHANGE THESE CONDITIONS. SINCE WE ARE
    707. 

  707. !***  DEALING WITH SLOPES TO GENERATE DIAMOND SHAPE H BOXES, WE NEED TO BE
    708. 

  708. !***  CAREFUL HERE      
    709. 

  709. !
    710. 

  710. 

  711.     IF(ABS(TLON-TLONHC) .LE. 1.E-4)TLONHC=TLON
    712. 

  712.     IF(ABS(TLAT-TLATHC) .LE. 1.E-4)TLATHC=TLAT
    713. 

  713.     DENOM=(TLON-TLONHC)
    714. 

  714. !
    715. 

  715. !***
    716. 

  716. !***STORE THE LOCATION OF THE WESTERNMOST VERTEX OF THE H-BOX ON
    717. 

  717. !***THE OUTER GRID THAT SURROUNDS THE h POINT ON THE INNER GRID.
    718. 

  718. !***
    719. 

  719. !*** COINCIDENT CONDITIONS
    720. 

  720. 

  721.     IF(DENOM.EQ.0.0)THEN
    722. 

  722. 

  723.       IF(TLATHC.EQ.TLAT)THEN
    724. 

  724.         KOUTB(I,J)=K
    725. 

  725.         IIH(I,J) = NCOL
    726. 

  726.         JJH(I,J) = NROW
    727. 

  727.         TLATHX(I,J)=TLATHC
    728. 

  728.         TLONHX(I,J)=TLONHC
    729. 

  729.         HBWGT1(I,J)=1.0
    730. 

  730.         HBWGT2(I,J)=0.0
    731. 

  731.         HBWGT3(I,J)=0.0
    732. 

  732.         HBWGT4(I,J)=0.0
    733. 

  733.       ELSE                                      ! SAME LONGITUDE BUT DIFFERENT LATS
    734. 

  734. !
    735. 

  735.          IF(TLATHC .GT. TLAT)THEN      ! NESTED POINT SOUTH OF PARENT
    736. 

  736.           KOUTB(I,J)=K-(P_IDE-1)
    737. 

  737.           IIH(I,J) = NCOL-1
    738. 

  738.           JJH(I,J) = NROW-1
    739. 

  739.           TLATHX(I,J)=TLATHC-DPH
    740. 

  740.           TLONHX(I,J)=TLONHC-DLM
    741. 

  741.          ELSE                                   ! NESTED POINT NORTH OF PARENT
    742. 

  742.           KOUTB(I,J)=K+(P_IDE-1)-1
    743. 

  743.           IIH(I,J) = NCOL-1
    744. 

  744.           JJH(I,J) = NROW+1
    745. 

  745.           TLATHX(I,J)=TLATHC+DPH
    746. 

  746.           TLONHX(I,J)=TLONHC-DLM
    747. 

  747.          ENDIF
    748. 

  748. !***
    749. 

  749. !***
    750. 

  750. !***                  4
    751. 

  751. !***
    752. 

  752. !***                  H
    753. 

  753. !***             1         2
    754. 

  754. !***
    755. 

  755. !***                  3
    756. 

  756. !***  DL 1-4 ARE THE ANGULAR DISTANCES FROM h TO EACH VERTEX
    757. 

  757. 

  758.        TLATO=TLATHX(I,J)
    759. 

  759.        TLONO=TLONHX(I,J)
    760. 

  760.        DLM1=TLON-TLONO
    761. 

  761.        DLA1=TLAT-TLATO                                               ! Q
    762. 

  762. !      DL1=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM1)+SIN(TLAT)*SIN(TLATO)) ! Q
    763. 

  763.        DL1=SQRT(DLM1*DLM1+DLA1*DLA1)                                 ! Q 
    764. 

  764. !
    765. 

  765.        TLATO=TLATHX(I,J)
    766. 

  766.        TLONO=TLONHX(I,J)+2.*DLM
    767. 

  767.        DLM2=TLON-TLONO
    768. 

  768.        DLA2=TLAT-TLATO                                               ! Q
    769. 

  769. !      DL2=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM2)+SIN(TLAT)*SIN(TLATO)) ! Q
    770. 

  770.        DL2=SQRT(DLM2*DLM2+DLA2*DLA2)                                 ! Q
    771. 

  771. ! 
    772. 

  772.        TLATO=TLATHX(I,J)-DPH
    773. 

  773.        TLONO=TLONHX(I,J)+DLM
    774. 

  774.        DLM3=TLON-TLONO
    775. 

  775.        DLA3=TLAT-TLATO                                               ! Q
    776. 

  776. !      DL3=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM3)+SIN(TLAT)*SIN(TLATO)) ! Q
    777. 

  777.        DL3=SQRT(DLM3*DLM3+DLA3*DLA3)                                 ! Q
    778. 

  778.  
    779. 

  779.        TLATO=TLATHX(I,J)+DPH
    780. 

  780.        TLONO=TLONHX(I,J)+DLM
    781. 

  781.        DLM4=TLON-TLONO
    782. 

  782.        DLA4=TLAT-TLATO                                               ! Q
    783. 

  783. !      DL4=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM4)+SIN(TLAT)*SIN(TLATO)) ! Q
    784. 

  784.        DL4=SQRT(DLM4*DLM4+DLA4*DLA4)                                 ! Q
    785. 

  785. 

  786. 

  787. !      THE BILINEAR WEIGHTS
    788. 

  788. !***
    789. 

  789. !***
    790. 

  790.        AN3=ATAN2(DLA1,DLM1)                                          ! Q
    791. 

  791.        R1=DL1*SIN(AN2-AN3)/SIN(2.*AN1)
    792. 

  792.        S1=DL1*SIN(2.*PI_2-2*AN1-AN2+AN3)/SIN(2.*AN1)
    793. 

  793.        R1=R1/DS1
    794. 

  794.        S1=S1/DS1
    795. 

  795.        DL1I=(1.-R1)*(1.-S1)
    796. 

  796.        DL2I=R1*S1
    797. 

  797.        DL3I=R1*(1.-S1)
    798. 

  798.        DL4I=(1.-R1)*S1
    799. 

  799. !
    800. 

  800.        HBWGT1(I,J)=DL1I
    801. 

  801.        HBWGT2(I,J)=DL2I
    802. 

  802.        HBWGT3(I,J)=DL3I
    803. 

  803.        HBWGT4(I,J)=DL4I
    804. 

  804. ! 
    805. 

  805.       ENDIF
    806. 

  806. 

  807.     ELSE
    808. 

  808. !
    809. 

  809. !*** NON-COINCIDENT POINTS   
    810. 

  810. !
    811. 

  811.       SLOPE=(TLAT-TLATHC)/DENOM
    812. 

  812.       DSLOPE=NINT(R2D*ATAN(SLOPE))
    813. 

  813. 

  814.       IF(DSLOPE.LE.DSLP0.AND.DSLOPE.GE.-DSLP0)THEN
    815. 

  815.         IF(TLON.GT.TLONHC)THEN
    816. 

  816.           IF(TLONHC.GE.-WB-DLM)CALL wrf_error_fatal("1H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
    817. 

  817.           KOUTB(I,J)=K
    818. 

  818.           IIH(I,J) = NCOL
    819. 

  819.           JJH(I,J) = NROW
    820. 

  820.           TLATHX(I,J)=TLATHC
    821. 

  821.           TLONHX(I,J)=TLONHC
    822. 

  822.         ELSE
    823. 

  823.           IF(TLONHC.LE.WB+DLM)CALL wrf_error_fatal("2H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
    824. 

  824.           KOUTB(I,J)=K-1
    825. 

  825.           IIH(I,J) = NCOL-2
    826. 

  826.           JJH(I,J) = NROW
    827. 

  827.           TLATHX(I,J)=TLATHC
    828. 

  828.           TLONHX(I,J)=TLONHC -2.*DLM
    829. 

  829.         ENDIF
    830. 

  830. 

  831. !
    832. 

  832.       ELSEIF(DSLOPE.GT.DSLP0)THEN
    833. 

  833.         IF(TLON.GT.TLONHC)THEN
    834. 

  834.           IF(TLATHC.GE.-SB-DPH)CALL wrf_error_fatal("3H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
    835. 

  835.           KOUTB(I,J)=K+(P_IDE-1)-1
    836. 

  836.           IIH(I,J) = NCOL-1
    837. 

  837.           JJH(I,J) = NROW+1
    838. 

  838.           TLATHX(I,J)=TLATHC+DPH
    839. 

  839.           TLONHX(I,J)=TLONHC-DLM
    840. 

  840.         ELSE
    841. 

  841.           IF(TLATHC.LE.SB+DPH)CALL wrf_error_fatal("4H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
    842. 

  842.           KOUTB(I,J)=K-(P_IDE-1)
    843. 

  843.           IIH(I,J) = NCOL-1
    844. 

  844.           JJH(I,J) = NROW-1
    845. 

  845.           TLATHX(I,J)=TLATHC-DPH
    846. 

  846.           TLONHX(I,J)=TLONHC-DLM
    847. 

  847.         ENDIF
    848. 

  848. 

  849. !
    850. 

  850.       ELSEIF(DSLOPE.LT.-DSLP0)THEN
    851. 

  851.         IF(TLON.GT.TLONHC)THEN
    852. 

  852.           IF(TLATHC.LE.SB+DPH)CALL wrf_error_fatal("5H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
    853. 

  853.           KOUTB(I,J)=K-(P_IDE-1)
    854. 

  854.           IIH(I,J) = NCOL-1
    855. 

  855.           JJH(I,J) = NROW-1
    856. 

  856.           TLATHX(I,J)=TLATHC-DPH
    857. 

  857.           TLONHX(I,J)=TLONHC-DLM
    858. 

  858.         ELSE
    859. 

  859.           IF(TLATHC.GE.-SB-DPH)CALL wrf_error_fatal("6H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
    860. 

  860.           KOUTB(I,J)=K+(P_IDE-1)-1
    861. 

  861.           IIH(I,J) = NCOL-1
    862. 

  862.           JJH(I,J) = NROW+1
    863. 

  863.           TLATHX(I,J)=TLATHC+DPH
    864. 

  864.           TLONHX(I,J)=TLONHC-DLM
    865. 

  865.         ENDIF
    866. 

  866.       ENDIF
    867. 

  867. 

  868. !
    869. 

  869. !***  NOW WE WILL MOVE AS FOLLOWS:
    870. 

  870. !***
    871. 

  871. !***
    872. 

  872. !***                      4
    873. 

  873. !***
    874. 

  874. !***
    875. 

  875. !***  
    876. 

  876. !***                   H
    877. 

  877. !***             1                 2
    878. 

  878. !***
    879. 

  879. !***
    880. 

  880. !***
    881. 

  881. !***
    882. 

  882. !***                      3
    883. 

  883. !***
    884. 

  884. !***
    885. 

  885. !***
    886. 

  886. !***  DL 1-4 ARE THE ANGULAR DISTANCES FROM h TO EACH VERTEX
    887. 

  887.       
    888. 

  888.       TLATO=TLATHX(I,J)
    889. 

  889.       TLONO=TLONHX(I,J)
    890. 

  890.       DLM1=TLON-TLONO
    891. 

  891.       DLA1=TLAT-TLATO                                               ! Q
    892. 

  892. !     DL1=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM1)+SIN(TLAT)*SIN(TLATO)) ! Q
    893. 

  893.       DL1=SQRT(DLM1*DLM1+DLA1*DLA1)                                 ! Q
    894. 

  894. !
    895. 

  895.       TLATO=TLATHX(I,J)                                             ! redundant computations
    896. 

  896.       TLONO=TLONHX(I,J)+2.*DLM
    897. 

  897.       DLM2=TLON-TLONO
    898. 

  898.       DLA2=TLAT-TLATO                                               ! Q
    899. 

  899. !     DL2=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM2)+SIN(TLAT)*SIN(TLATO)) ! Q
    900. 

  900.       DL2=SQRT(DLM2*DLM2+DLA2*DLA2)                                 ! Q
    901. 

  901. !
    902. 

  902.       TLATO=TLATHX(I,J)-DPH
    903. 

  903.       TLONO=TLONHX(I,J)+DLM
    904. 

  904.       DLM3=TLON-TLONO
    905. 

  905.       DLA3=TLAT-TLATO                                               ! Q
    906. 

  906. !     DL3=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM3)+SIN(TLAT)*SIN(TLATO)) ! Q
    907. 

  907.       DL3=SQRT(DLM3*DLM3+DLA3*DLA3)                                 ! Q
    908. 

  908. !
    909. 

  909.       TLATO=TLATHX(I,J)+DPH
    910. 

  910.       TLONO=TLONHX(I,J)+DLM
    911. 

  911.       DLM4=TLON-TLONO
    912. 

  912.       DLA4=TLAT-TLATO                                               ! Q
    913. 

  913. !     DL4=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM4)+SIN(TLAT)*SIN(TLATO)) ! Q
    914. 

  914.       DL4=SQRT(DLM4*DLM4+DLA4*DLA4)                                 ! Q
    915. 

  915. 

  916. !     THE BILINEAR WEIGHTS
    917. 

  917. !***
    918. 

  918.       AN3=ATAN2(DLA1,DLM1)                                          ! Q
    919. 

  919.       R1=DL1*SIN(AN2-AN3)/SIN(2.*AN1)
    920. 

  920.       S1=DL1*SIN(2.*PI_2-2*AN1-AN2+AN3)/SIN(2.*AN1)
    921. 

  921.       R1=R1/DS1
    922. 

  922.       S1=S1/DS1
    923. 

  923.       DL1I=(1.-R1)*(1.-S1)
    924. 

  924.       DL2I=R1*S1
    925. 

  925.       DL3I=R1*(1.-S1)
    926. 

  926.       DL4I=(1.-R1)*S1
    927. 

  927. !
    928. 

  928.       HBWGT1(I,J)=DL1I
    929. 

  929.       HBWGT2(I,J)=DL2I
    930. 

  930.       HBWGT3(I,J)=DL3I
    931. 

  931.       HBWGT4(I,J)=DL4I
    932. 

  932. !
    933. 

  933.     ENDIF 
    934. 

  934. 

  935. !
    936. 

  936. !***  FINALLY STORE IIH IN TERMS OF E-GRID INDEX
    937. 

  937. !
    938. 

  938.       IIH(I,J)=NINT(0.5*IIH(I,J))
    939. 

  939. 

  940.       HBWGT1(I,J)=MAX(HBWGT1(I,J),0.0)   ! all weights must be GE zero (postive def)
    941. 

  941.       HBWGT2(I,J)=MAX(HBWGT2(I,J),0.0)   ! all weights must be GE zero (postive def)
    942. 

  942.       HBWGT3(I,J)=MAX(HBWGT3(I,J),0.0)   ! all weights must be GE zero (postive def)
    943. 

  943.       HBWGT4(I,J)=MAX(HBWGT4(I,J),0.0)   ! all weights must be GE zero (postive def)
    944. 

  944. 

  945. !      write(message,105)"H WEIGHTS:",I,J,HBWGT1(I,J),HBWGT2(I,J),HBWGT3(I,J),HBWGT4(I,J), &
    946. 

  946. !                               HBWGT1(I,J)+HBWGT2(I,J)+HBWGT3(I,J)+HBWGT4(I,J),IIH(i,j),JJH(i,j)
    947. 

  947. !      CALL wrf_message(trim(message))
    948. 

  948. ! 105  format(a,2i4,5f7.3,2i4)
    949. 

  949. 

  950.    ENDDO
    951. 

  951.   ENDDO
    952. 

  952. 

  953. 

  954.   RETURN 
    955. 

  955.   END SUBROUTINE G2T2H
    956. 

  956. !========================================================================================
    957. 

  957. 

  958. 

  959.   SUBROUTINE G2T2V( IIV,JJV,                     & ! output grid index and weights
    960. 

  960.                     VBWGT1,VBWGT2,               & ! output weights in terms of parent grid
    961. 

  961.                     VBWGT3,VBWGT4,               &
    962. 

  962.                     VLAT,VLON,                   & ! target (nest) input lat lon in degrees
    963. 

  963.                     DLMD1,DPHD1,WBD1,SBD1,       & ! parent res, west and south boundaries
    964. 

  964.                     CENTRAL_LAT,CENTRAL_LON,     & ! parent central lat,lon, all in degrees
    965. 

  965.                     P_IDE,P_JDE,                 & ! parent imax and jmax
    966. 

  966.                     IDS,IDE,JDS,JDE,KDS,KDE,     & ! target (nest) dIMEnsions
    967. 

  967.                     IMS,IME,JMS,JME,KMS,KME,     &
    968. 

  968.                     ITS,ITE,JTS,JTE,KTS,KTE      )
    969. 

  969. 

  970. !
    971. 

  971. !***  Tom Black   - Initial Version 
    972. 

  972. !***  Gopal       - Revised Version for WRF (includes coincIDEnt grid points)
    973. 

  973. !***
    974. 

  974. !***  GIVEN PARENT CENTRAL LAT-LONS, RESOLUTION AND WESTERN AND SOUTHERN BOUNDARY,
    975. 

  975. !***  AND THE NESTED GRID LAT-LONS AT V POINTS, THIS ROUTINE FIRST LOCATES THE
    976. 

  976. !***  INDICES,IIV,JJV, OF THE PARENT DOMAIN'S V POINTS THAT LIES CLOSEST TO THE
    977. 

  977. !***  V POINTS OF THE NESTED DOMAIN
    978. 

  978. !
    979. 

  979. !============================================================================
    980. 

  980. 

  981.  IMPLICIT NONE
    982. 

  982.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    983. 

  983.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    984. 

  984.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    985. 

  985.  INTEGER,    INTENT(IN   )                            :: P_IDE,P_JDE
    986. 

  986.  REAL,       INTENT(IN   )                            :: DLMD1,DPHD1,WBD1,SBD1
    987. 

  987.  REAL,       INTENT(IN   )                            :: CENTRAL_LAT,CENTRAL_LON
    988. 

  988.  REAL,    DIMENSION(IMS:IME,JMS:JME),   INTENT(IN)    :: VLAT,VLON
    989. 

  989.  REAL,    DIMENSION(IMS:IME,JMS:JME),   INTENT(OUT)   :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
    990. 

  990.  INTEGER, DIMENSION(IMS:IME,JMS:JME),   INTENT(OUT)   :: IIV,JJV
    991. 

  991. 

  992. ! local
    993. 

  993. 

  994.  INTEGER,PARAMETER :: KNUM=SELECTED_REAL_KIND(13)     ! (6) single precision
    995. 

  995.  INTEGER           :: IMT,JMT,N2R,MK,K,I,J,DSLP0,DSLOPE
    996. 

  996.  INTEGER           :: NROW,NCOL,KROWS
    997. 

  997.  REAL(KIND=KNUM)   :: X,Y,Z,TLAT,TLON
    998. 

  998.  REAL(KIND=KNUM)   :: PI_2,D2R,R2D,GLAT,GLON,DPH,DLM,TPH0,TLM0,WB,SB
    999. 

  999.  REAL(KIND=KNUM)   :: ROW,COL,SLP0,TLATVC,TLONVC,DENOM,SLOPE
    1000. 

  1000.  REAL(KIND=KNUM)   :: TLAT1,TLAT2,TLON1,TLON2,DLM1,DLM2,DLM3,DLM4,D1,D2
    1001. 

  1001.  REAL(KIND=KNUM)   :: DLA1,DLA2,DLA3,DLA4,S1,R1,DS1,AN1,AN2,AN3                    ! Q
    1002. 

  1002.  REAL(KIND=KNUM)   :: DL1,DL2,DL3,DL4,DL1I,DL2I,DL3I,DL4I,SUMDL,TLONO,TLATO
    1003. 

  1003.  REAL(KIND=KNUM)   :: DTEMP
    1004. 

  1004.  REAL  , DIMENSION(IMS:IME,JMS:JME)      :: TLATVX,TLONVX
    1005. 

  1005.  INTEGER, DIMENSION(IMS:IME,JMS:JME)     :: KOUTB
    1006. 

  1006. !-------------------------------------------------------------------------------------
    1007. 

  1007. 

  1008.   IMT=2*P_IDE-2             ! parent i dIMEnsions
    1009. 

  1009.   JMT=P_JDE/2               ! parent j dIMEnsions
    1010. 

  1010.   PI_2=ACOS(0.)
    1011. 

  1011.   D2R=PI_2/90.
    1012. 

  1012.   R2D=1./D2R
    1013. 

  1013.   DPH=DPHD1*D2R
    1014. 

  1014.   DLM=DLMD1*D2R
    1015. 

  1015.   TPH0= CENTRAL_LAT*D2R
    1016. 

  1016.   TLM0=-CENTRAL_LON*D2R        ! NOTE THE MINUS HERE
    1017. 

  1017.   WB=WBD1*D2R                   ! DEGREES TO RADIANS
    1018. 

  1018.   SB=SBD1*D2R
    1019. 

  1019.   SLP0=DPHD1/DLMD1
    1020. 

  1020.   DSLP0=NINT(R2D*ATAN(SLP0))
    1021. 

  1021.   DS1=SQRT(DPH*DPH+DLM*DLM)    ! Q
    1022. 

  1022.   AN1=ASIN(DLM/DS1)
    1023. 

  1023.   AN2=ASIN(DPH/DS1)
    1024. 

  1024. 

  1025.   DO J =  JTS,MIN(JTE,JDE-1)
    1026. 

  1026.     DO I = ITS,MIN(ITE,IDE-1)
    1027. 

  1027. !***
    1028. 

  1028. !***  LOCATE TARGET V POINTS (VLAT AND VLON) ON THE PARENT DOMAIN AND
    1029. 

  1029. !***  DETERMINE THE INDICES IN TERMS OF THE PARENT DOMAIN. FIRST
    1030. 

  1030. !***  CONVERT NESTED GRID V POINTS FROM GEODETIC TO TRANSFORMED
    1031. 

  1031. !***  COORDINATE ON THE PARENT GRID
    1032. 

  1032. !
    1033. 

  1033. 

  1034.       GLAT=VLAT(I,J)*D2R
    1035. 

  1035.       GLON=(360. - VLON(I,J))*D2R
    1036. 

  1036.       X=COS(TPH0)*COS(GLAT)*COS(GLON-TLM0)+SIN(TPH0)*SIN(GLAT)
    1037. 

  1037.       Y=-COS(GLAT)*SIN(GLON-TLM0)
    1038. 

  1038.       Z=COS(TPH0)*SIN(GLAT)-SIN(TPH0)*COS(GLAT)*COS(GLON-TLM0)
    1039. 

  1039.       TLAT=R2D*ATAN(Z/SQRT(X*X+Y*Y))
    1040. 

  1040.       TLON=R2D*ATAN(Y/X)
    1041. 

  1041. 

  1042. !      ROW=TLAT/DPHD1+JMT         ! JMT IS THE CENTRAL ROW OF THE PARENT DOMAIN
    1043. 

  1043. !      COL=TLON/DLMD1+P_IDE-1     ! (P_IDE-1) IS THE CENTRAL COLUMN OF THE PARENT DOMAIN
    1044. 

  1044. 

  1045.       ROW=(TLAT-SBD1)/DPHD1+1     ! Dusan's doing
    1046. 

  1046.       COL=(TLON-WBD1)/DLMD1+1     ! Dusan's doing
    1047. 

    1048. 

  1048.       NROW=INT(ROW + 0.001)     ! ROUND-OFF IS AVOIDED WITHOUT USING NINT ON PURPOSE
    1049. 

  1049.       NCOL=INT(COL + 0.001)
    1050. 

  1050.       TLAT=TLAT*D2R
    1051. 

  1051.       TLON=TLON*D2R
    1052. 

  1052. 

  1053. !***
    1054. 

  1054. !***
    1055. 

  1055. !***  FIRST CONSIDER THE SITUATION WHERE THE POINT V IS AT
    1056. 

  1056. !***
    1057. 

  1057. !***              H      V
    1058. 

  1058. !***
    1059. 

  1059. !***
    1060. 

  1060. !***                 V
    1061. 

  1061. !***              V      H
    1062. 

  1062. !***
    1063. 

  1063. !***  THEN LOCATE THE NEAREST V POINT ON THE PARENT GRID
    1064. 

  1064. !***
    1065. 

  1065. 

  1066.       IF(MOD(NROW,2).EQ.0.AND.MOD(NCOL,2).EQ.1.OR.     &
    1067. 

  1067.          MOD(NROW,2).EQ.1.AND.MOD(NCOL,2).EQ.0)THEN
    1068. 

  1068.            TLAT1=(NROW-JMT)*DPH
    1069. 

  1069.            TLAT2=TLAT1+DPH
    1070. 

  1070.            TLON1=(NCOL-(P_IDE-1))*DLM
    1071. 

  1071.            TLON2=TLON1+DLM
    1072. 

  1072.            DLM1=TLON-TLON1
    1073. 

  1073.            DLM2=TLON-TLON2
    1074. 

  1074. !           D1=ACOS(COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
    1075. 

  1075. !           D2=ACOS(COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
    1076. 

  1076.            DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
    1077. 

  1077.            D1=ACOS(DTEMP)
    1078. 

  1078.            DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
    1079. 

  1079.            D2=ACOS(DTEMP)
    1080. 

  1080.             IF(D1.GT.D2)THEN
    1081. 

  1081.              NROW=NROW+1                    ! FIND THE NEAREST V ROW
    1082. 

  1082.              NCOL=NCOL+1                    ! FIND THE NEAREST V COLUMN
    1083. 

  1083.             ENDIF
    1084. 

  1084.       ELSE
    1085. 

  1085. 

  1086. !***
    1087. 

  1087. !***  NOW CONSIDER THE SITUATION WHERE THE POINT V IS AT
    1088. 

  1088. !***
    1089. 

  1089. !***              V      H
    1090. 

  1090. !***
    1091. 

  1091. !***
    1092. 

  1092. !***                 V
    1093. 

  1093. !***              H      V
    1094. 

  1094. !***
    1095. 

  1095. !*** THEN LOCATE THE NEAREST V POINT ON THE PARENT GRID
    1096. 

  1096. !***
    1097. 

  1097.            TLAT1=(NROW+1-JMT)*DPH
    1098. 

  1098.            TLAT2=TLAT1-DPH
    1099. 

  1099.            TLON1=(NCOL-(P_IDE-1))*DLM
    1100. 

  1100.            TLON2=TLON1+DLM
    1101. 

  1101.            DLM1=TLON-TLON1
    1102. 

  1102.            DLM2=TLON-TLON2
    1103. 

  1103. !           D1=ACOS(COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
    1104. 

  1104. !           D2=ACOS(COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
    1105. 

  1105.            DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
    1106. 

  1106.            D1=ACOS(DTEMP)
    1107. 

  1107.            DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
    1108. 

  1108.            D2=ACOS(DTEMP)
    1109. 

  1109.              IF(D1.LT.D2)THEN
    1110. 

  1110.               NROW=NROW+1                    ! FIND THE NEAREST H ROW
    1111. 

  1111.              ELSE
    1112. 

  1112.               NCOL=NCOL+1                    ! FIND THE NEAREST H COLUMN
    1113. 

  1113.              ENDIF
    1114. 

  1114. 

  1115.       ENDIF
    1116. 

  1116. 

  1117.       KROWS=((NROW-1)/2)*IMT
    1118. 

  1118.       IF(MOD(NROW,2).EQ.1)THEN
    1119. 

  1119.         K=KROWS+NCOL/2
    1120. 

  1120.       ELSE
    1121. 

  1121.         K=KROWS+P_IDE-2+(NCOL+1)/2     ! check this one should this not be P_IDE-2 ????
    1122. 

  1122.       ENDIF
    1123. 

  1123. 

  1124. !***
    1125. 

  1125. !***  WE NOW KNOW THAT THE INNER GRID POINT IN QUESTION IS
    1126. 

  1126. !***  NEAREST TO THE CENTER K AS SEEN BELOW.  WE MUST FIND
    1127. 

  1127. !***  WHICH OF THE FOUR v-BOXES (OF WHICH THIS V POINT IS
    1128. 

  1128. !***  A VERTEX) SURROUNDS THE INNER GRID V POINT IN QUESTION.
    1129. 

  1129. !***
    1130. 

  1130. !***
    1131. 

  1131. !***                  V
    1132. 

  1132. !***
    1133. 

  1133. !***
    1134. 

  1134. !***
    1135. 

  1135. !***            V     H     V
    1136. 

  1136. !***
    1137. 

  1137. !***
    1138. 

  1138. !***               V
    1139. 

  1139. !***      V     H     V     H     V
    1140. 

  1140. !***
    1141. 

  1141. !***
    1142. 

  1142. !***
    1143. 

  1143. !***            V     H     V
    1144. 

  1144. !***
    1145. 

  1145. !***
    1146. 

  1146. !***
    1147. 

  1147. !***                  V
    1148. 

  1148. !***
    1149. 

  1149. !***
    1150. 

  1150. !***  FIND THE SLOPE OF THE LINE CONNECTING V AND THE CENTER v.
    1151. 

  1151. !***
    1152. 

  1152.       N2R=K/IMT
    1153. 

  1153.       MK=MOD(K,IMT)
    1154. 

  1154. !
    1155. 

  1155.       IF(MK.EQ.0)THEN
    1156. 

  1156.         TLATVC=SB+(2*N2R-1)*DPH
    1157. 

  1157.       ELSE
    1158. 

  1158.         TLATVC=SB+(2*N2R+MK/(P_IDE-1))*DPH
    1159. 

  1159.       ENDIF
    1160. 

  1160. !
    1161. 

  1161.       IF(MK.LE.(P_IDE-1)-1)THEN
    1162. 

  1162.         TLONVC=WB+(2*MK-1)*DLM
    1163. 

  1163.       ELSE
    1164. 

  1164.         TLONVC=WB+2*(MK-(P_IDE-1))*DLM
    1165. 

  1165.       ENDIF
    1166. 

  1166. 

  1167. !
    1168. 

  1168. !***  EXECUTE CAUTION IF YOU NEED TO CHANGE THESE CONDITIONS. SINCE WE ARE
    1169. 

  1169. !***  DEALING WITH SLOPES TO GENERATE DIAMOND SHAPE V BOXES, WE NEED TO BE
    1170. 

  1170. !***  CAREFUL HERE
    1171. 

  1171. !
    1172. 

  1172.        IF(ABS(TLON-TLONVC) .LE. 1.E-4)TLONVC=TLON
    1173. 

  1173.        IF(ABS(TLAT-TLATVC) .LE. 1.E-4)TLATVC=TLAT
    1174. 

  1174.        DENOM=(TLON-TLONVC)
    1175. 

  1175. !
    1176. 

  1176. !***
    1177. 

  1177. !***STORE THE LOCATION OF THE WESTERNMOST VERTEX OF THE H-BOX ON
    1178. 

  1178. !***THE OUTER GRID THAT SURROUNDS THE h POINT ON THE INNER GRID.
    1179. 

  1179. !***
    1180. 

  1180. !*** COINCIDENT CONDITIONS
    1181. 

  1181. 

  1182.      IF(DENOM.EQ.0.0)THEN
    1183. 

  1183. 

  1184.        IF(TLATVC.EQ.TLAT)THEN
    1185. 

  1185.          KOUTB(I,J)=K
    1186. 

  1186.          IIV(I,J) = NCOL
    1187. 

  1187.          JJV(I,J) = NROW
    1188. 

  1188.          TLATVX(I,J)=TLATVC
    1189. 

  1189.          TLONVX(I,J)=TLONVC
    1190. 

  1190.          VBWGT1(I,J)=1.0
    1191. 

  1191.          VBWGT2(I,J)=0.0
    1192. 

  1192.          VBWGT3(I,J)=0.0
    1193. 

  1193.          VBWGT4(I,J)=0.0
    1194. 

  1194.        ELSE                              ! SAME LONGITUDE BUT DIFFERENT LATS 
    1195. 

  1195.           
    1196. 

  1196.          IF(TLATVC .GT. TLAT)THEN      ! NESTED POINT SOUTH OF PARENT
    1197. 

  1197.           KOUTB(I,J)=K-(P_IDE-1)
    1198. 

  1198.           IIV(I,J) = NCOL-1
    1199. 

  1199.           JJV(I,J) = NROW-1
    1200. 

  1200.           TLATVX(I,J)=TLATVC-DPH
    1201. 

  1201.           TLONVX(I,J)=TLONVC-DLM
    1202. 

  1202.          ELSE                                   ! NESTED POINT NORTH OF PARENT
    1203. 

  1203.           KOUTB(I,J)=K+(P_IDE-1)-1
    1204. 

  1204.           IIV(I,J) = NCOL-1
    1205. 

  1205.           JJV(I,J) = NROW+1
    1206. 

  1206.           TLATVX(I,J)=TLATVC+DPH
    1207. 

  1207.           TLONVX(I,J)=TLONVC-DLM
    1208. 

  1208.          ENDIF
    1209. 

  1209. 

  1210. !***
    1211. 

  1211. !***
    1212. 

  1212. !***                  4
    1213. 

  1213. !***
    1214. 

  1214. !***                  V 
    1215. 

  1215. !***             1         2
    1216. 

  1216. !***
    1217. 

  1217. !***                  3
    1218. 

  1218. !***  DL 1-4 ARE THE ANGULAR DISTANCES FROM h TO EACH VERTEX
    1219. 

  1219. 

  1220.        TLATO=TLATVX(I,J)
    1221. 

  1221.        TLONO=TLONVX(I,J)
    1222. 

  1222.        DLM1=TLON-TLONO
    1223. 

  1223.        DLA1=TLAT-TLATO                                               ! Q
    1224. 

  1224. !      DL1=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM1)+SIN(TLAT)*SIN(TLATO)) ! Q
    1225. 

  1225.        DL1=SQRT(DLM1*DLM1+DLA1*DLA1)                                 ! Q
    1226. 

  1226. !
    1227. 

  1227.        TLATO=TLATVX(I,J)
    1228. 

  1228.        TLONO=TLONVX(I,J)+2.*DLM
    1229. 

  1229.        DLM2=TLON-TLONO
    1230. 

  1230.        DLA2=TLAT-TLATO                                               ! Q
    1231. 

  1231. !      DL2=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM2)+SIN(TLAT)*SIN(TLATO)) ! Q
    1232. 

  1232.        DL2=SQRT(DLM2*DLM2+DLA2*DLA2)                                 ! Q
    1233. 

  1233. 

  1234.        TLATO=TLATVX(I,J)-DPH
    1235. 

  1235.        TLONO=TLONVX(I,J)+DLM
    1236. 

  1236.        DLM3=TLON-TLONO
    1237. 

  1237.        DLA3=TLAT-TLATO                                               ! Q
    1238. 

  1238. !      DL3=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM3)+SIN(TLAT)*SIN(TLATO)) ! Q
    1239. 

  1239.        DL3=SQRT(DLM3*DLM3+DLA3*DLA3)                                 ! Q
    1240. 

  1240. 

  1241.        TLATO=TLATVX(I,J)+DPH
    1242. 

  1242.        TLONO=TLONVX(I,J)+DLM
    1243. 

  1243.        DLM4=TLON-TLONO
    1244. 

  1244.        DLA4=TLAT-TLATO                                               ! Q
    1245. 

  1245. !      DL4=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM4)+SIN(TLAT)*SIN(TLATO)) ! Q
    1246. 

  1246.        DL4=SQRT(DLM4*DLM4+DLA4*DLA4)                                 ! Q
    1247. 

  1247.                  
    1248. 

  1248. !      THE BILINEAR WEIGHTS
    1249. 

  1249. !***
    1250. 

  1250.        AN3=ATAN2(DLA1,DLM1)                                          ! Q
    1251. 

  1251.        R1=DL1*SIN(AN2-AN3)/SIN(2.*AN1)
    1252. 

  1252.        S1=DL1*SIN(2.*PI_2-2*AN1-AN2+AN3)/SIN(2.*AN1)
    1253. 

  1253.        R1=R1/DS1
    1254. 

  1254.        S1=S1/DS1
    1255. 

  1255.        DL1I=(1.-R1)*(1.-S1)
    1256. 

  1256.        DL2I=R1*S1
    1257. 

  1257.        DL3I=R1*(1.-S1)
    1258. 

  1258.        DL4I=(1.-R1)*S1
    1259. 

  1259. !
    1260. 

  1260.        VBWGT1(I,J)=DL1I
    1261. 

  1261.        VBWGT2(I,J)=DL2I
    1262. 

  1262.        VBWGT3(I,J)=DL3I
    1263. 

  1263.        VBWGT4(I,J)=DL4I      
    1264. 

  1264. 

  1265.       ENDIF
    1266. 

  1266. 

  1267.     ELSE
    1268. 

  1268. 

  1269. !
    1270. 

  1270. !*** NON-COINCIDENT POINTS
    1271. 

  1271. !
    1272. 

  1272.       SLOPE=(TLAT-TLATVC)/DENOM
    1273. 

  1273.       DSLOPE=NINT(R2D*ATAN(SLOPE))
    1274. 

  1274. 

  1275.       IF(DSLOPE.LE.DSLP0.AND.DSLOPE.GE.-DSLP0)THEN
    1276. 

  1276.         IF(TLON.GT.TLONVC)THEN
    1277. 

  1277.           IF(TLONVC.GE.-WB-DLM)CALL wrf_error_fatal("1V:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
    1278. 

  1278.           KOUTB(I,J)=K
    1279. 

  1279.           IIV(I,J)=NCOL
    1280. 

  1280.           JJV(I,J)=NROW
    1281. 

  1281.           TLATVX(I,J)=TLATVC
    1282. 

  1282.           TLONVX(I,J)=TLONVC
    1283. 

  1283.         ELSE
    1284. 

  1284.           IF(TLONVC.LE.WB+DLM)CALL wrf_error_fatal("2V:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
    1285. 

  1285.           KOUTB(I,J)=K-1
    1286. 

  1286.           IIV(I,J) = NCOL-2
    1287. 

  1287.           JJV(I,J) = NROW
    1288. 

  1288.           TLATVX(I,J)=TLATVC
    1289. 

  1289.           TLONVX(I,J)=TLONVC-2.*DLM
    1290. 

  1290.         ENDIF
    1291. 

  1291.  
    1292. 

  1292.       ELSEIF(DSLOPE.GT.DSLP0)THEN
    1293. 

  1293.         IF(TLON.GT.TLONVC)THEN
    1294. 

  1294.           IF(TLATVC.GE.-SB-DPH)CALL wrf_error_fatal("3V:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
    1295. 

  1295.           KOUTB(I,J)=K+(P_IDE-1)-1
    1296. 

  1296.           IIV(I,J) = NCOL-1
    1297. 

  1297.           JJV(I,J) = NROW+1
    1298. 

  1298.           TLATVX(I,J)=TLATVC+DPH
    1299. 

  1299.           TLONVX(I,J)=TLONVC-DLM
    1300. 

  1300.         ELSE
    1301. 

  1301.           IF(TLATVC.LE.SB+DPH)CALL wrf_error_fatal("4V:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
    1302. 

  1302.           KOUTB(I,J)=K-(P_IDE-1)
    1303. 

  1303.           IIV(I,J) = NCOL-1
    1304. 

  1304.           JJV(I,J) = NROW-1
    1305. 

  1305.           TLATVX(I,J)=TLATVC-DPH
    1306. 

  1306.           TLONVX(I,J)=TLONVC-DLM
    1307. 

  1307.         ENDIF
    1308. 

  1308.  
    1309. 

  1309.       ELSEIF(DSLOPE.LT.-DSLP0)THEN
    1310. 

  1310.         IF(TLON.GT.TLONVC)THEN
    1311. 

  1311.           IF(TLATVC.LE.SB+DPH)CALL wrf_error_fatal("5V:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
    1312. 

  1312.           KOUTB(I,J)=K-(P_IDE-1)
    1313. 

  1313.           IIV(I,J) = NCOL-1
    1314. 

  1314.           JJV(I,J) = NROW-1
    1315. 

  1315.           TLATVX(I,J)=TLATVC-DPH
    1316. 

  1316.           TLONVX(I,J)=TLONVC-DLM
    1317. 

  1317.         ELSE
    1318. 

  1318.           IF(TLATVC.GE.-SB-DPH)CALL wrf_error_fatal("6V:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
    1319. 

  1319.           KOUTB(I,J)=K+(P_IDE-1)-1
    1320. 

  1320.           IIV(I,J) = NCOL-1
    1321. 

  1321.           JJV(I,J) = NROW+1
    1322. 

  1322.           TLATVX(I,J)=TLATVC+DPH
    1323. 

  1323.           TLONVX(I,J)=TLONVC-DLM
    1324. 

  1324.         ENDIF
    1325. 

  1325.       ENDIF
    1326. 

  1326. !
    1327. 

  1327. !***  NOW WE WILL MOVE AS FOLLOWS:
    1328. 

  1328. !***
    1329. 

  1329. !***
    1330. 

  1330. !***                      4
    1331. 

  1331. !***
    1332. 

  1332. !***
    1333. 

  1333. !*** 
    1334. 

  1334. !***                   V 
    1335. 

  1335. !***             1                 2
    1336. 

  1336. !***
    1337. 

  1337. !***
    1338. 

  1338. !***
    1339. 

  1339. !***
    1340. 

  1340. !***                      3
    1341. 

  1341. !***
    1342. 

  1342. !***
    1343. 

  1343. !***
    1344. 

  1344. !***  DL 1-4 ARE THE ANGULAR DISTANCES FROM V TO EACH VERTEX
    1345. 

  1345. 

  1346.       TLATO=TLATVX(I,J)
    1347. 

  1347.       TLONO=TLONVX(I,J)
    1348. 

  1348.       DLM1=TLON-TLONO
    1349. 

  1349.       DLA1=TLAT-TLATO                                               ! Q
    1350. 

  1350. !     DL1=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM1)+SIN(TLAT)*SIN(TLATO)) ! Q
    1351. 

  1351.       DL1=SQRT(DLM1*DLM1+DLA1*DLA1)                                 ! Q
    1352. 

  1352. !
    1353. 

  1353.       TLATO=TLATVX(I,J)
    1354. 

  1354.       TLONO=TLONVX(I,J)+2.*DLM
    1355. 

  1355.       DLM2=TLON-TLONO
    1356. 

  1356.       DLA2=TLAT-TLATO                                               ! Q
    1357. 

  1357. !     DL2=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM2)+SIN(TLAT)*SIN(TLATO)) ! Q
    1358. 

  1358.       DL2=SQRT(DLM2*DLM2+DLA2*DLA2)                                 ! Q
    1359. 

  1359. !
    1360. 

  1360.       TLATO=TLATVX(I,J)-DPH
    1361. 

  1361.       TLONO=TLONVX(I,J)+DLM
    1362. 

  1362.       DLM3=TLON-TLONO
    1363. 

  1363.       DLA3=TLAT-TLATO                                               ! Q
    1364. 

  1364. !     DL3=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM3)+SIN(TLAT)*SIN(TLATO)) ! Q
    1365. 

  1365.       DL3=SQRT(DLM3*DLM3+DLA3*DLA3)                                 ! Q
    1366. 

  1366. !
    1367. 

  1367.       TLATO=TLATVX(I,J)+DPH
    1368. 

  1368.       TLONO=TLONVX(I,J)+DLM
    1369. 

  1369.       DLM4=TLON-TLONO
    1370. 

  1370.       DLA4=TLAT-TLATO                                               ! Q
    1371. 

  1371. !     DL4=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM4)+SIN(TLAT)*SIN(TLATO)) ! Q
    1372. 

  1372.       DL4=SQRT(DLM4*DLM4+DLA4*DLA4)                                 ! Q
    1373. 

  1373.  
    1374. 

  1374. !     THE BILINEAR WEIGHTS
    1375. 

  1375. !***
    1376. 

  1376.       AN3=ATAN2(DLA1,DLM1)                                          ! Q
    1377. 

  1377.       R1=DL1*SIN(AN2-AN3)/SIN(2.*AN1)
    1378. 

  1378.       S1=DL1*SIN(2.*PI_2-2*AN1-AN2+AN3)/SIN(2.*AN1)
    1379. 

  1379.       R1=R1/DS1
    1380. 

  1380.       S1=S1/DS1
    1381. 

  1381.       DL1I=(1.-R1)*(1.-S1)
    1382. 

  1382.       DL2I=R1*S1
    1383. 

  1383.       DL3I=R1*(1.-S1)
    1384. 

  1384.       DL4I=(1.-R1)*S1
    1385. 

  1385. !
    1386. 

  1386.       VBWGT1(I,J)=DL1I
    1387. 

  1387.       VBWGT2(I,J)=DL2I
    1388. 

  1388.       VBWGT3(I,J)=DL3I
    1389. 

  1389.       VBWGT4(I,J)=DL4I
    1390. 

  1390. 

  1391.      ENDIF
    1392. 

  1392. 

  1393. !
    1394. 

  1394. !***  FINALLY STORE IIH IN TERMS OF E-GRID INDEX
    1395. 

  1395. !
    1396. 

  1396.       IIV(I,J)=NINT(0.5*IIV(I,J))
    1397. 

  1397. 

  1398.       VBWGT1(I,J)=MAX(VBWGT1(I,J),0.0)   ! all weights must be GE zero (postive def)
    1399. 

  1399.       VBWGT2(I,J)=MAX(VBWGT2(I,J),0.0)   ! all weights must be GE zero (postive def)
    1400. 

  1400.       VBWGT3(I,J)=MAX(VBWGT3(I,J),0.0)   ! all weights must be GE zero (postive def)
    1401. 

  1401.       VBWGT4(I,J)=MAX(VBWGT4(I,J),0.0)   ! all weights must be GE zero (postive def)
    1402. 

  1402. 

  1403.     ENDDO
    1404. 

  1404.   ENDDO
    1405. 

  1405. 

  1406.  RETURN
    1407. 

  1407.  END SUBROUTINE G2T2V
    1408. 

  1408. 

  1409. !-----------------------------------------------------------------------------  
    1410. 

  1410. 

  1411.  SUBROUTINE G2T2H_new( IIH,JJH,                            & ! output grid index and weights 
    1412. 

  1412.                        HBWGT1,HBWGT2,                      & ! output weights in terms of parent grid
    1413. 

  1413.                        HBWGT3,HBWGT4,                      &
    1414. 

  1414.                        I_PARENT_START,J_PARENT_START,      & ! nest start I and J in parent domain  
    1415. 

  1415.                        RATIO,                              & ! Ratio of parent and child grid ( always = 3 for NMM)
    1416. 

  1416.                        IDS,IDE,JDS,JDE,KDS,KDE,            & ! target (nest) dimensions
    1417. 

  1417.                        IMS,IME,JMS,JME,KMS,KME,            &
    1418. 

  1418.                        ITS,ITE,JTS,JTE,KTS,KTE      )
    1419. 

  1419. !
    1420. 

  1420. !*** XUEJIN ZHANG --- Initial version (09/08/2008)
    1421. 

  1421. !*** XUEJIN ZHANG --- Modified for parallel purpose (09/10/2009)
    1422. 

  1422. !*** XUEJIN ZHANG --- Modified for parallel purpose (09/29/2009)
    1423. 

  1423. !Function: Bilnear interpolation weight and indexing for E-grid
    1424. 

  1424. !
    1425. 

  1425.  IMPLICIT NONE
    1426. 

  1426.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    1427. 

  1427.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    1428. 

  1428.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    1429. 

  1429.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    1430. 

  1430.  INTEGER,    INTENT(IN   )                            :: RATIO
    1431. 

  1431.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    1432. 

  1432.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
    1433. 

  1433. !LOCAL VARIABLES
    1434. 

  1434.  INTEGER                                              :: I,J
    1435. 

  1435.  INTEGER                                              :: JP
    1436. 

  1436. 

  1437. 

  1438. !*** ARRANGEMENT OF 4 VERTEXES FROM PARENT DOMAIN
    1439. 

  1439. !***
    1440. 

  1440. !***                  4
    1441. 

  1441. !***
    1442. 

  1442. !***                  h
    1443. 

  1443. !***             1         2
    1444. 

  1444. !***
    1445. 

  1445. !***
    1446. 

  1446. !***                  3
    1447. 

  1447. !
    1448. 

  1448. !************************************************************* 
    1449. 

  1449. !***  POINT (i,j) SPANS 9 NESTED POINTS 
    1450. 

  1450. !***  A VERTEX IN THE NEST DOMAIN AND INDEXING FOR PARENT DOMAIN 
    1451. 

  1451. !***
    1452. 

  1452. !***
    1453. 

  1453. !***                  H
    1454. 

  1454. !***                
    1455. 

  1455. !***               h     h
    1456. 

  1456. !***              / \
    1457. 

  1457. !***            h     h     h
    1458. 

  1458. !***           / \   / \
    1459. 

  1459. !***         H     h     h     H  
    1460. 

  1460. !***          \   / \   /   
    1461. 

  1461. !***            h     h     h
    1462. 

  1462. !***             \   /
    1463. 

  1463. !***               h     h
    1464. 

  1464. !***      
    1465. 

  1465. !***                  H
    1466. 

  1466. !***                 
    1467. 

  1467. !***
    1468. 

  1468. !***
    1469. 

  1469. !************************************************************* 
    1470. 

  1470. !*** MOVING NEST ALWAYS STARTING FROM MASS GRID H
    1471. 

  1471. !*** PLEASE REFER TO E-GRID ARRANGEMENT FIGURE FOR MASS POINTS
    1472. 

  1472. 

  1473. 

  1474.  DO J=JTS,MIN(JTE,JDE-1)
    1475. 

  1475.  DO I=ITS,MIN(ITE,IDE-1)
    1476. 

  1476.     JP = MOD(J,RATIO*2)
    1477. 

  1477.     SELECT CASE(JP)
    1478. 

  1478.     CASE ( 1 )
    1479. 

  1479.       CALL SUB1H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
    1480. 

  1480.                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1481. 

  1481.                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1482. 

  1482.                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1483. 

  1483.                 IMS,IME,JMS,JME,KMS,KME,                 &
    1484. 

  1484.                 ITS,ITE,JTS,JTE,KTS,KTE      )
    1485. 

  1485.     CASE ( 2 )
    1486. 

  1486.       CALL SUB2H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &    
    1487. 

  1487.                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1488. 

  1488.                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1489. 

  1489.                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1490. 

  1490.                 IMS,IME,JMS,JME,KMS,KME,                 &
    1491. 

  1491.                 ITS,ITE,JTS,JTE,KTS,KTE      )
    1492. 

  1492.     CASE ( 3 )
    1493. 

  1493.       CALL SUB3H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
    1494. 

  1494.                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1495. 

  1495.                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1496. 

  1496.                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1497. 

  1497.                 IMS,IME,JMS,JME,KMS,KME,                 &
    1498. 

  1498.                 ITS,ITE,JTS,JTE,KTS,KTE      )
    1499. 

  1499.     CASE ( 4 )
    1500. 

  1500.       CALL SUB4H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &    
    1501. 

  1501.                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1502. 

  1502.                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1503. 

  1503.                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1504. 

  1504.                 IMS,IME,JMS,JME,KMS,KME,                 &
    1505. 

  1505.                 ITS,ITE,JTS,JTE,KTS,KTE      )
    1506. 

  1506.     CASE ( 5 )
    1507. 

  1507.       CALL SUB5H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
    1508. 

  1508.                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1509. 

  1509.                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1510. 

  1510.                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1511. 

  1511.                 IMS,IME,JMS,JME,KMS,KME,                 &
    1512. 

  1512.                 ITS,ITE,JTS,JTE,KTS,KTE      )
    1513. 

  1513.     CASE ( 0 )
    1514. 

  1514.       CALL SUB6H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &    
    1515. 

  1515.                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1516. 

  1516.                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1517. 

  1517.                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1518. 

  1518.                 IMS,IME,JMS,JME,KMS,KME,                 &
    1519. 

  1519.                 ITS,ITE,JTS,JTE,KTS,KTE      )
    1520. 

  1520.     END SELECT
    1521. 

  1521. #if defined(EXPENSIVE_HWRF_DEBUG_STUFF)
    1522. 

  1522.        write(0,105)"NEW H WEIGHTS:",I,J,IIH(i,j),JJH(i,j),HBWGT1(I,J),HBWGT2(I,J),HBWGT3(I,J),HBWGT4(I,J), &
    1523. 

  1523.                                 HBWGT1(I,J)+HBWGT2(I,J)+HBWGT3(I,J)+HBWGT4(I,J)
    1524. 

  1524. #endif
    1525. 

  1525.   105  format(a,4i4,5f7.3)
    1526. 

  1526.  END DO
    1527. 

  1527.  END DO
    1528. 

  1528. 

  1529.  RETURN
    1530. 

  1530.  END SUBROUTINE G2T2H_new
    1531. 

  1531.  SUBROUTINE SUB1H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
    1532. 

  1532.                  I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1533. 

  1533.                  RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1534. 

  1534.                  IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1535. 

  1535.                  IMS,IME,JMS,JME,KMS,KME,                 &
    1536. 

  1536.                  ITS,ITE,JTS,JTE,KTS,KTE      )
    1537. 

  1537.  IMPLICIT NONE
    1538. 

  1538.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    1539. 

  1539.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    1540. 

  1540.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    1541. 

  1541.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    1542. 

  1542.  INTEGER,    INTENT(IN   )                            :: RATIO
    1543. 

  1543.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    1544. 

  1544.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
    1545. 

  1545. !LOCAL VARIABLES
    1546. 

  1546.  INTEGER                                              :: I,J
    1547. 

  1547.  INTEGER                                              :: IP
    1548. 

  1548. 

  1549.   IP = MOD(I,RATIO)
    1550. 

  1550.   SELECT CASE(IP)
    1551. 

  1551.    CASE ( 1 )
    1552. 

  1552.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1553. 

  1553.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1554. 

  1554.     HBWGT1(I,J) = 1.0
    1555. 

  1555.     HBWGT2(I,J) = 0.0
    1556. 

  1556.     HBWGT3(I,J) = 0.0
    1557. 

  1557.     HBWGT4(I,J) = 0.0
    1558. 

  1558.    CASE ( 2 )
    1559. 

  1559.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1560. 

  1560.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1561. 

  1561.     HBWGT1(I,J) = 4.0/9.0
    1562. 

  1562.     HBWGT2(I,J) = 1.0/9.0
    1563. 

  1563.     HBWGT3(I,J) = 2.0/9.0
    1564. 

  1564.     HBWGT4(I,J) = 2.0/9.0
    1565. 

  1565.    CASE ( 0 )
    1566. 

  1566.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1567. 

  1567.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1568. 

  1568.     HBWGT1(I,J) = 1.0/9.0
    1569. 

  1569.     HBWGT2(I,J) = 4.0/9.0
    1570. 

  1570.     HBWGT3(I,J) = 2.0/9.0
    1571. 

  1571.     HBWGT4(I,J) = 2.0/9.0
    1572. 

  1572.    END SELECT
    1573. 

  1573.  RETURN
    1574. 

  1574.  END SUBROUTINE SUB1H
    1575. 

  1575.  SUBROUTINE SUB2H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
    1576. 

  1576.                  I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1577. 

  1577.                  RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1578. 

  1578.                  IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1579. 

  1579.                  IMS,IME,JMS,JME,KMS,KME,                 &
    1580. 

  1580.                  ITS,ITE,JTS,JTE,KTS,KTE      )
    1581. 

  1581.  IMPLICIT NONE
    1582. 

  1582.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    1583. 

  1583.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    1584. 

  1584.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    1585. 

  1585.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    1586. 

  1586.  INTEGER,    INTENT(IN   )                            :: RATIO
    1587. 

  1587.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    1588. 

  1588.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
    1589. 

  1589. !LOCAL VARIABLES
    1590. 

  1590.  INTEGER                                              :: I,J
    1591. 

  1591.  INTEGER                                              :: IP
    1592. 

  1592. 

  1593.   IP = MOD(I,RATIO)
    1594. 

  1594.   SELECT CASE(IP)
    1595. 

  1595.    CASE ( 1 )
    1596. 

  1596.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1597. 

  1597.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1598. 

  1598.     HBWGT1(I,J) = 2.0/3.0
    1599. 

  1599.     HBWGT2(I,J) = 0.0
    1600. 

  1600.     HBWGT3(I,J) = 0.0
    1601. 

  1601.     HBWGT4(I,J) = 1.0/3.0
    1602. 

  1602.    CASE ( 2 )
    1603. 

  1603.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1604. 

  1604.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1605. 

  1605.     HBWGT1(I,J) = 2.0/9.0
    1606. 

  1606.     HBWGT2(I,J) = 2.0/9.0
    1607. 

  1607.     HBWGT3(I,J) = 1.0/9.0
    1608. 

  1608.     HBWGT4(I,J) = 4.0/9.0
    1609. 

  1609.    CASE ( 0 )
    1610. 

  1610.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1611. 

  1611.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)+1
    1612. 

  1612.     HBWGT1(I,J) = 1.0/3.0
    1613. 

  1613.     HBWGT2(I,J) = 0.0
    1614. 

  1614.     HBWGT3(I,J) = 2.0/3.0
    1615. 

  1615.     HBWGT4(I,J) = 0.0
    1616. 

  1616.    END SELECT
    1617. 

  1617.  RETURN
    1618. 

  1618.  END SUBROUTINE SUB2H
    1619. 

  1619.  SUBROUTINE SUB3H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
    1620. 

  1620.                  I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1621. 

  1621.                  RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1622. 

  1622.                  IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1623. 

  1623.                  IMS,IME,JMS,JME,KMS,KME,                 &
    1624. 

  1624.                  ITS,ITE,JTS,JTE,KTS,KTE      )
    1625. 

  1625.  IMPLICIT NONE
    1626. 

  1626.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    1627. 

  1627.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    1628. 

  1628.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    1629. 

  1629.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    1630. 

  1630.  INTEGER,    INTENT(IN   )                            :: RATIO
    1631. 

  1631.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    1632. 

  1632.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
    1633. 

  1633. !LOCAL VARIABLES
    1634. 

  1634.  INTEGER                                              :: I,J
    1635. 

  1635.  INTEGER                                              :: IP
    1636. 

  1636. 

  1637.   IP = MOD(I,RATIO)
    1638. 

  1638.   SELECT CASE(IP)
    1639. 

  1639.    CASE ( 1 )
    1640. 

  1640.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)-1
    1641. 

  1641.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)+1
    1642. 

  1642.     HBWGT1(I,J) = 2.0/9.0
    1643. 

  1643.     HBWGT2(I,J) = 2.0/9.0
    1644. 

  1644.     HBWGT3(I,J) = 4.0/9.0
    1645. 

  1645.     HBWGT4(I,J) = 1.0/9.0
    1646. 

  1646.    CASE ( 2 )
    1647. 

  1647.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1648. 

  1648.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1649. 

  1649.     HBWGT1(I,J) = 1.0/3.0
    1650. 

  1650.     HBWGT2(I,J) = 0.0
    1651. 

  1651.     HBWGT3(I,J) = 0.0
    1652. 

  1652.     HBWGT4(I,J) = 2.0/3.0
    1653. 

  1653.    CASE ( 0 )
    1654. 

  1654.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1655. 

  1655.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)+1
    1656. 

  1656.     HBWGT1(I,J) = 2.0/3.0
    1657. 

  1657.     HBWGT2(I,J) = 0.0
    1658. 

  1658.     HBWGT3(I,J) = 1.0/3.0
    1659. 

  1659.     HBWGT4(I,J) = 0.0
    1660. 

  1660.    END SELECT
    1661. 

  1661.  RETURN
    1662. 

  1662.  END SUBROUTINE SUB3H
    1663. 

  1663.  SUBROUTINE SUB4H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
    1664. 

  1664.                  I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1665. 

  1665.                  RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1666. 

  1666.                  IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1667. 

  1667.                  IMS,IME,JMS,JME,KMS,KME,                 &
    1668. 

  1668.                  ITS,ITE,JTS,JTE,KTS,KTE      )
    1669. 

  1669.  IMPLICIT NONE
    1670. 

  1670.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    1671. 

  1671.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    1672. 

  1672.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    1673. 

  1673.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    1674. 

  1674.  INTEGER,    INTENT(IN   )                            :: RATIO
    1675. 

  1675.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    1676. 

  1676.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
    1677. 

  1677. !LOCAL VARIABLES
    1678. 

  1678.  INTEGER                                              :: I,J
    1679. 

  1679.  INTEGER                                              :: IP
    1680. 

  1680. 

  1681.   IP = MOD(I,RATIO)
    1682. 

  1682.   SELECT CASE(IP)
    1683. 

  1683.    CASE ( 1 )
    1684. 

  1684.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)-1
    1685. 

  1685.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1686. 

  1686.     HBWGT1(I,J) = 1.0/9.0
    1687. 

  1687.     HBWGT2(I,J) = 4.0/9.0
    1688. 

  1688.     HBWGT3(I,J) = 2.0/9.0
    1689. 

  1689.     HBWGT4(I,J) = 2.0/9.0
    1690. 

  1690.    CASE ( 2 )
    1691. 

  1691.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1692. 

  1692.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1693. 

  1693.     HBWGT1(I,J) = 1.0
    1694. 

  1694.     HBWGT2(I,J) = 0.0
    1695. 

  1695.     HBWGT3(I,J) = 0.0
    1696. 

  1696.     HBWGT4(I,J) = 0.0
    1697. 

  1697.    CASE ( 0 )
    1698. 

  1698.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1699. 

  1699.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1700. 

  1700.     HBWGT1(I,J) = 4.0/9.0
    1701. 

  1701.     HBWGT2(I,J) = 1.0/9.0
    1702. 

  1702.     HBWGT3(I,J) = 2.0/9.0
    1703. 

  1703.     HBWGT4(I,J) = 2.0/9.0
    1704. 

  1704.    END SELECT
    1705. 

  1705.  RETURN
    1706. 

  1706.  END SUBROUTINE SUB4H
    1707. 

  1707.  SUBROUTINE SUB5H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
    1708. 

  1708.                  I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1709. 

  1709.                  RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1710. 

  1710.                  IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1711. 

  1711.                  IMS,IME,JMS,JME,KMS,KME,                 &
    1712. 

  1712.                  ITS,ITE,JTS,JTE,KTS,KTE      )
    1713. 

  1713.  IMPLICIT NONE
    1714. 

  1714.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    1715. 

  1715.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    1716. 

  1716.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    1717. 

  1717.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    1718. 

  1718.  INTEGER,    INTENT(IN   )                            :: RATIO
    1719. 

  1719.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    1720. 

  1720.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
    1721. 

  1721. !LOCAL VARIABLES
    1722. 

  1722.  INTEGER                                              :: I,J
    1723. 

  1723.  INTEGER                                              :: IP
    1724. 

  1724. 

  1725.   IP = MOD(I,RATIO)
    1726. 

  1726.   SELECT CASE(IP)
    1727. 

  1727.    CASE ( 1 )
    1728. 

  1728.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)-1
    1729. 

  1729.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1730. 

  1730.     HBWGT1(I,J) = 2.0/9.0
    1731. 

  1731.     HBWGT2(I,J) = 2.0/9.0
    1732. 

  1732.     HBWGT3(I,J) = 1.0/9.0
    1733. 

  1733.     HBWGT4(I,J) = 4.0/9.0
    1734. 

  1734.    CASE ( 2 )
    1735. 

  1735.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1736. 

  1736.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)+1
    1737. 

  1737.     HBWGT1(I,J) = 1.0/3.0
    1738. 

  1738.     HBWGT2(I,J) = 0.0
    1739. 

  1739.     HBWGT3(I,J) = 2.0/3.0
    1740. 

  1740.     HBWGT4(I,J) = 0.0
    1741. 

  1741.    CASE ( 0 )
    1742. 

  1742.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1743. 

  1743.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1744. 

  1744.     HBWGT1(I,J) = 2.0/3.0
    1745. 

  1745.     HBWGT2(I,J) = 0.0
    1746. 

  1746.     HBWGT3(I,J) = 0.0
    1747. 

  1747.     HBWGT4(I,J) = 1.0/3.0
    1748. 

  1748.    END SELECT
    1749. 

  1749.  RETURN
    1750. 

  1750.  END SUBROUTINE SUB5H
    1751. 

  1751.  SUBROUTINE SUB6H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
    1752. 

  1752.                  I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1753. 

  1753.                  RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1754. 

  1754.                  IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1755. 

  1755.                  IMS,IME,JMS,JME,KMS,KME,                 &
    1756. 

  1756.                  ITS,ITE,JTS,JTE,KTS,KTE      )
    1757. 

  1757.  IMPLICIT NONE
    1758. 

  1758.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    1759. 

  1759.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    1760. 

  1760.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    1761. 

  1761.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    1762. 

  1762.  INTEGER,    INTENT(IN   )                            :: RATIO
    1763. 

  1763.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    1764. 

  1764.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
    1765. 

  1765. !LOCAL VARIABLES
    1766. 

  1766.  INTEGER                                              :: I,J
    1767. 

  1767.  INTEGER                                              :: IP
    1768. 

  1768. 

  1769.   IP = MOD(I,RATIO)
    1770. 

  1770.   SELECT CASE(IP)
    1771. 

  1771.    CASE ( 1 )
    1772. 

  1772.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1773. 

  1773.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
    1774. 

  1774.     HBWGT1(I,J) = 2.0/3.0
    1775. 

  1775.     HBWGT2(I,J) = 0.0
    1776. 

  1776.     HBWGT3(I,J) = 1.0/3.0
    1777. 

  1777.     HBWGT4(I,J) = 0.0
    1778. 

  1778.    CASE ( 2 )
    1779. 

  1779.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1780. 

  1780.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
    1781. 

  1781.     HBWGT1(I,J) = 2.0/9.0
    1782. 

  1782.     HBWGT2(I,J) = 2.0/9.0
    1783. 

  1783.     HBWGT3(I,J) = 4.0/9.0
    1784. 

  1784.     HBWGT4(I,J) = 1.0/9.0
    1785. 

  1785.    CASE ( 0 )
    1786. 

  1786.     IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1787. 

  1787.     JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1788. 

  1788.     HBWGT1(I,J) = 1.0/3.0
    1789. 

  1789.     HBWGT2(I,J) = 0.0
    1790. 

  1790.     HBWGT3(I,J) = 0.0
    1791. 

  1791.     HBWGT4(I,J) = 2.0/3.0
    1792. 

  1792.    END SELECT
    1793. 

  1793.  RETURN
    1794. 

  1794.  END SUBROUTINE SUB6H
    1795. 

  1795. 

  1796. !-----------------------------------------------------------------------------  
    1797. 

  1797. 

  1798.  SUBROUTINE G2T2V_new( IIV,JJV,                            & ! output grid index and weights 
    1799. 

  1799.                        VBWGT1,VBWGT2,                      & ! output weights in terms of parent grid
    1800. 

  1800.                        VBWGT3,VBWGT4,                      &
    1801. 

  1801.                        I_PARENT_START,J_PARENT_START,      & ! nest start I and J in parent domain  
    1802. 

  1802.                        RATIO,                              & ! Ratio of parent and child grid ( always = 3 for NMM)
    1803. 

  1803.                        IDS,IDE,JDS,JDE,KDS,KDE,            & ! target (nest) dimensions
    1804. 

  1804.                        IMS,IME,JMS,JME,KMS,KME,            &
    1805. 

  1805.                        ITS,ITE,JTS,JTE,KTS,KTE      )
    1806. 

  1806. !
    1807. 

  1807. !*** XUEJIN ZHANG --- Initial version (09/08/2008)
    1808. 

  1808. !*** XUEJIN ZHANG --- Modified for parallel purpose (09/10/2009)
    1809. 

  1809. !*** XUEJIN ZHANG --- Modified for parallel purpose (09/29/2009)
    1810. 

  1810. !Function: Bilnear interpolation weight and indexing for E-grid
    1811. 

  1811. !
    1812. 

  1812.  IMPLICIT NONE
    1813. 

  1813.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    1814. 

  1814.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    1815. 

  1815.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    1816. 

  1816.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    1817. 

  1817.  INTEGER,    INTENT(IN   )                            :: RATIO
    1818. 

  1818.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
    1819. 

  1819.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
    1820. 

  1820. !LOCAL VARIABLES
    1821. 

  1821.  INTEGER                                              :: I,J
    1822. 

  1822.  INTEGER                                              :: JP
    1823. 

  1823. 

  1824. !*** ARRANGEMENT OF 4 VERTEXES FROM PARENT DOMAIN
    1825. 

  1825. !***
    1826. 

  1826. !***                  4
    1827. 

  1827. !***
    1828. 

  1828. !***                  v
    1829. 

  1829. !***             1         2
    1830. 

  1830. !***
    1831. 

  1831. !***
    1832. 

  1832. !***                  3
    1833. 

  1833. !
    1834. 

  1834. !************************************************************* 
    1835. 

  1835. !***  POINT (i,j) SPANS 9 NESTED POINTS 
    1836. 

  1836. !***  A VERTEX IN THE NEST DOMAIN AND INDEXING FOR PARENT DOMAIN
    1837. 

  1837. !***
    1838. 

  1838. !***
    1839. 

  1839. !***                  V
    1840. 

  1840. !***                
    1841. 

  1841. !***               v  h  v
    1842. 

  1842. !***              / \
    1843. 

  1843. !***            v  h  v  h  v
    1844. 

  1844. !***           / \   / \
    1845. 

  1845. !***         V  H  v  h  v  h  V  H
    1846. 

  1846. !***          \   / \   /   
    1847. 

  1847. !***            v  h  v  h  v
    1848. 

  1848. !***             \   /
    1849. 

  1849. !***               v  h  v
    1850. 

  1850. !***      
    1851. 

  1851. !***                  V
    1852. 

  1852. !***                 
    1853. 

  1853. !***
    1854. 

  1854. !***
    1855. 

  1855. !************************************************************* 
    1856. 

  1856. !*** MOVING NEST ALWAYS STARTING FROM MASS GRID H
    1857. 

  1857. !*** PLEASE REFER TO E-GRID ARRANGEMENT FIGURE FOR WIND POINTS
    1858. 

  1858. 

  1859.  DO J=JTS,MIN(JTE,JDE-1)
    1860. 

  1860.  DO I=ITS,MIN(ITE,IDE-1)
    1861. 

  1861.     JP = MOD(J,RATIO*2)
    1862. 

  1862.     SELECT CASE(JP)
    1863. 

  1863.     CASE ( 1 )
    1864. 

  1864.       CALL SUB1V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
    1865. 

  1865.                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1866. 

  1866.                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1867. 

  1867.                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1868. 

  1868.                 IMS,IME,JMS,JME,KMS,KME,                 &
    1869. 

  1869.                 ITS,ITE,JTS,JTE,KTS,KTE      )
    1870. 

  1870.     CASE ( 2 )
    1871. 

  1871.       CALL SUB2V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &    
    1872. 

  1872.                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1873. 

  1873.                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1874. 

  1874.                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1875. 

  1875.                 IMS,IME,JMS,JME,KMS,KME,                 &
    1876. 

  1876.                 ITS,ITE,JTS,JTE,KTS,KTE      )
    1877. 

  1877.     CASE ( 3 )
    1878. 

  1878.       CALL SUB3V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
    1879. 

  1879.                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1880. 

  1880.                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1881. 

  1881.                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1882. 

  1882.                 IMS,IME,JMS,JME,KMS,KME,                 &
    1883. 

  1883.                 ITS,ITE,JTS,JTE,KTS,KTE      )
    1884. 

  1884.     CASE ( 4 )
    1885. 

  1885.       CALL SUB4V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &    
    1886. 

  1886.                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1887. 

  1887.                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1888. 

  1888.                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1889. 

  1889.                 IMS,IME,JMS,JME,KMS,KME,                 &
    1890. 

  1890.                 ITS,ITE,JTS,JTE,KTS,KTE      )
    1891. 

  1891.     CASE ( 5 )
    1892. 

  1892.       CALL SUB5V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
    1893. 

  1893.                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1894. 

  1894.                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1895. 

  1895.                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1896. 

  1896.                 IMS,IME,JMS,JME,KMS,KME,                 &
    1897. 

  1897.                 ITS,ITE,JTS,JTE,KTS,KTE      )
    1898. 

  1898.     CASE ( 0 )
    1899. 

  1899.       CALL SUB6V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &    
    1900. 

  1900.                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1901. 

  1901.                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1902. 

  1902.                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1903. 

  1903.                 IMS,IME,JMS,JME,KMS,KME,                 &
    1904. 

  1904.                 ITS,ITE,JTS,JTE,KTS,KTE      )
    1905. 

  1905.     END SELECT
    1906. 

  1906. !      WRITE(0,105)'NEW V WEIGHTS:',I,J,VBWGT1(I,J),VBWGT2(I,J),VBWGT3(I,J),VBWGT4(I,J), &
    1907. 

  1907. !                    VBWGT1(I,J)+VBWGT2(I,J)+VBWGT3(I,J)+VBWGT4(I,J),IIV(i,j),JJV(i,j)
    1908. 

  1908. ! 105  format(a,2i4,5f7.3,2i4)
    1909. 

  1909.  END DO
    1910. 

  1910.  END DO
    1911. 

  1911. 

  1912.  RETURN
    1913. 

  1913.  END SUBROUTINE G2T2V_new
    1914. 

  1914.  SUBROUTINE SUB1V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
    1915. 

  1915.                  I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1916. 

  1916.                  RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1917. 

  1917.                  IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1918. 

  1918.                  IMS,IME,JMS,JME,KMS,KME,                 &
    1919. 

  1919.                  ITS,ITE,JTS,JTE,KTS,KTE      )
    1920. 

  1920.  IMPLICIT NONE
    1921. 

  1921.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    1922. 

  1922.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    1923. 

  1923.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    1924. 

  1924.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    1925. 

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

  1926.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
    1927. 

  1927.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
    1928. 

  1928. !LOCAL VARIABLES
    1929. 

  1929.  INTEGER                                              :: I,J
    1930. 

  1930.  INTEGER                                              :: IP
    1931. 

  1931.   IP = MOD(I,RATIO)
    1932. 

  1932.   SELECT CASE(IP)
    1933. 

  1933.    CASE ( 1 )
    1934. 

  1934.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO) - 1
    1935. 

  1935.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1936. 

  1936.     VBWGT1(I,J) = 1.0/9.0
    1937. 

  1937.     VBWGT2(I,J) = 4.0/9.0
    1938. 

  1938.     VBWGT3(I,J) = 2.0/9.0
    1939. 

  1939.     VBWGT4(I,J) = 2.0/9.0
    1940. 

  1940.    CASE ( 2 )
    1941. 

  1941.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO) 
    1942. 

  1942.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1943. 

  1943.     VBWGT1(I,J) = 1.0
    1944. 

  1944.     VBWGT2(I,J) = 0.0
    1945. 

  1945.     VBWGT3(I,J) = 0.0
    1946. 

  1946.     VBWGT4(I,J) = 0.0
    1947. 

  1947.    CASE ( 0 )
    1948. 

  1948.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1949. 

  1949.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1950. 

  1950.     VBWGT1(I,J) = 4.0/9.0
    1951. 

  1951.     VBWGT2(I,J) = 1.0/9.0
    1952. 

  1952.     VBWGT3(I,J) = 2.0/9.0
    1953. 

  1953.     VBWGT4(I,J) = 2.0/9.0
    1954. 

  1954.    END SELECT
    1955. 

  1955.  RETURN
    1956. 

  1956.  END SUBROUTINE SUB1V
    1957. 

  1957.  SUBROUTINE SUB2V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
    1958. 

  1958.                  I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    1959. 

  1959.                  RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    1960. 

  1960.                  IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    1961. 

  1961.                  IMS,IME,JMS,JME,KMS,KME,                 &
    1962. 

  1962.                  ITS,ITE,JTS,JTE,KTS,KTE      )
    1963. 

  1963.  IMPLICIT NONE
    1964. 

  1964.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    1965. 

  1965.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    1966. 

  1966.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    1967. 

  1967.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    1968. 

  1968.  INTEGER,    INTENT(IN   )                            :: RATIO
    1969. 

  1969.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
    1970. 

  1970.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
    1971. 

  1971. !LOCAL VARIABLES
    1972. 

  1972.  INTEGER                                              :: I,J
    1973. 

  1973.  INTEGER                                              :: IP
    1974. 

  1974.   IP = MOD(I,RATIO)
    1975. 

  1975.   SELECT CASE(IP)
    1976. 

  1976.    CASE ( 1 )
    1977. 

  1977.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO) - 1
    1978. 

  1978.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1979. 

  1979.     VBWGT1(I,J) = 2.0/9.0
    1980. 

  1980.     VBWGT2(I,J) = 2.0/9.0
    1981. 

  1981.     VBWGT3(I,J) = 1.0/9.0
    1982. 

  1982.     VBWGT4(I,J) = 4.0/9.0
    1983. 

  1983.    CASE ( 2 )
    1984. 

  1984.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1985. 

  1985.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
    1986. 

  1986.     VBWGT1(I,J) = 1.0/3.0
    1987. 

  1987.     VBWGT2(I,J) = 0.0
    1988. 

  1988.     VBWGT3(I,J) = 2.0/3.0
    1989. 

  1989.     VBWGT4(I,J) = 0.0
    1990. 

  1990.    CASE ( 0 )
    1991. 

  1991.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    1992. 

  1992.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    1993. 

  1993.     VBWGT1(I,J) = 2.0/3.0
    1994. 

  1994.     VBWGT2(I,J) = 0.0
    1995. 

  1995.     VBWGT3(I,J) = 0.0
    1996. 

  1996.     VBWGT4(I,J) = 1.0/3.0
    1997. 

  1997.    END SELECT
    1998. 

  1998.  RETURN
    1999. 

  1999.  END SUBROUTINE SUB2V
    2000. 

  2000.  SUBROUTINE SUB3V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
    2001. 

  2001.                  I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    2002. 

  2002.                  RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    2003. 

  2003.                  IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    2004. 

  2004.                  IMS,IME,JMS,JME,KMS,KME,                 &
    2005. 

  2005.                  ITS,ITE,JTS,JTE,KTS,KTE      )
    2006. 

  2006.  IMPLICIT NONE
    2007. 

  2007.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    2008. 

  2008.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    2009. 

  2009.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    2010. 

  2010.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    2011. 

  2011.  INTEGER,    INTENT(IN   )                            :: RATIO
    2012. 

  2012.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
    2013. 

  2013.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
    2014. 

  2014. !LOCAL VARIABLES
    2015. 

  2015.  INTEGER                                              :: I,J
    2016. 

  2016.  INTEGER                                              :: IP
    2017. 

  2017.   IP = MOD(I,RATIO)
    2018. 

  2018.   SELECT CASE(IP)
    2019. 

  2019.    CASE ( 1 )
    2020. 

  2020.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    2021. 

  2021.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
    2022. 

  2022.     VBWGT1(I,J) = 2.0/3.0
    2023. 

  2023.     VBWGT2(I,J) = 0.0
    2024. 

  2024.     VBWGT3(I,J) = 1.0/3.0
    2025. 

  2025.     VBWGT4(I,J) = 0.0
    2026. 

  2026.    CASE ( 2 )
    2027. 

  2027.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    2028. 

  2028.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
    2029. 

  2029.     VBWGT1(I,J) = 2.0/9.0
    2030. 

  2030.     VBWGT2(I,J) = 2.0/9.0
    2031. 

  2031.     VBWGT3(I,J) = 4.0/9.0
    2032. 

  2032.     VBWGT4(I,J) = 1.0/9.0
    2033. 

  2033.    CASE ( 0 )
    2034. 

  2034.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    2035. 

  2035.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    2036. 

  2036.     VBWGT1(I,J) = 1.0/3.0
    2037. 

  2037.     VBWGT2(I,J) = 0.0
    2038. 

  2038.     VBWGT3(I,J) = 0.0
    2039. 

  2039.     VBWGT4(I,J) = 2.0/3.0
    2040. 

  2040.    END SELECT
    2041. 

  2041.  RETURN
    2042. 

  2042.  END SUBROUTINE SUB3V
    2043. 

  2043.  SUBROUTINE SUB4V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
    2044. 

  2044.                  I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    2045. 

  2045.                  RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    2046. 

  2046.                  IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    2047. 

  2047.                  IMS,IME,JMS,JME,KMS,KME,                 &
    2048. 

  2048.                  ITS,ITE,JTS,JTE,KTS,KTE      )
    2049. 

  2049.  IMPLICIT NONE
    2050. 

  2050.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    2051. 

  2051.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    2052. 

  2052.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    2053. 

  2053.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    2054. 

  2054.  INTEGER,    INTENT(IN   )                            :: RATIO
    2055. 

  2055.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
    2056. 

  2056.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
    2057. 

  2057. !LOCAL VARIABLES
    2058. 

  2058.  INTEGER                                              :: I,J
    2059. 

  2059.  INTEGER                                              :: IP
    2060. 

  2060.   IP = MOD(I,RATIO)
    2061. 

  2061.   SELECT CASE(IP)
    2062. 

  2062.    CASE ( 1 )
    2063. 

  2063.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    2064. 

  2064.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    2065. 

  2065.     VBWGT1(I,J) = 1.0
    2066. 

  2066.     VBWGT2(I,J) = 0.0
    2067. 

  2067.     VBWGT3(I,J) = 0.0
    2068. 

  2068.     VBWGT4(I,J) = 0.0
    2069. 

  2069.    CASE ( 2 )
    2070. 

  2070.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    2071. 

  2071.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    2072. 

  2072.     VBWGT1(I,J) = 4.0/9.0
    2073. 

  2073.     VBWGT2(I,J) = 1.0/9.0
    2074. 

  2074.     VBWGT3(I,J) = 2.0/9.0
    2075. 

  2075.     VBWGT4(I,J) = 2.0/9.0
    2076. 

  2076.    CASE ( 0 )
    2077. 

  2077.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    2078. 

  2078.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    2079. 

  2079.     VBWGT1(I,J) = 1.0/9.0
    2080. 

  2080.     VBWGT2(I,J) = 4.0/9.0
    2081. 

  2081.     VBWGT3(I,J) = 2.0/9.0
    2082. 

  2082.     VBWGT4(I,J) = 2.0/9.0
    2083. 

  2083.    END SELECT
    2084. 

  2084.  RETURN
    2085. 

  2085.  END SUBROUTINE SUB4V
    2086. 

  2086.  SUBROUTINE SUB5V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
    2087. 

  2087.                  I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    2088. 

  2088.                  RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    2089. 

  2089.                  IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    2090. 

  2090.                  IMS,IME,JMS,JME,KMS,KME,                 &
    2091. 

  2091.                  ITS,ITE,JTS,JTE,KTS,KTE      )
    2092. 

  2092.  IMPLICIT NONE
    2093. 

  2093.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    2094. 

  2094.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    2095. 

  2095.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    2096. 

  2096.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    2097. 

  2097.  INTEGER,    INTENT(IN   )                            :: RATIO
    2098. 

  2098.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
    2099. 

  2099.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
    2100. 

  2100. !LOCAL VARIABLES
    2101. 

  2101.  INTEGER                                              :: I,J
    2102. 

  2102.  INTEGER                                              :: IP
    2103. 

  2103.   IP = MOD(I,RATIO)
    2104. 

  2104.   SELECT CASE(IP)
    2105. 

  2105.    CASE ( 1 )
    2106. 

  2106.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    2107. 

  2107.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    2108. 

  2108.     VBWGT1(I,J) = 2.0/3.0
    2109. 

  2109.     VBWGT2(I,J) = 0.0
    2110. 

  2110.     VBWGT3(I,J) = 0.0
    2111. 

  2111.     VBWGT4(I,J) = 1.0/3.0
    2112. 

  2112.    CASE ( 2 )
    2113. 

  2113.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    2114. 

  2114.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
    2115. 

  2115.     VBWGT1(I,J) = 2.0/9.0
    2116. 

  2116.     VBWGT2(I,J) = 2.0/9.0
    2117. 

  2117.     VBWGT3(I,J) = 1.0/9.0
    2118. 

  2118.     VBWGT4(I,J) = 4.0/9.0
    2119. 

  2119.    CASE ( 0 )
    2120. 

  2120.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    2121. 

  2121.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
    2122. 

  2122.     VBWGT1(I,J) = 1.0/3.0
    2123. 

  2123.     VBWGT2(I,J) = 0.0
    2124. 

  2124.     VBWGT3(I,J) = 2.0/3.0
    2125. 

  2125.     VBWGT4(I,J) = 0.0
    2126. 

  2126.    END SELECT
    2127. 

  2127.  RETURN
    2128. 

  2128.  END SUBROUTINE SUB5V
    2129. 

  2129.  SUBROUTINE SUB6V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
    2130. 

  2130.                  I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
    2131. 

  2131.                  RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
    2132. 

  2132.                  IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
    2133. 

  2133.                  IMS,IME,JMS,JME,KMS,KME,                 &
    2134. 

  2134.                  ITS,ITE,JTS,JTE,KTS,KTE      )
    2135. 

  2135.  IMPLICIT NONE
    2136. 

  2136.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    2137. 

  2137.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    2138. 

  2138.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    2139. 

  2139.  INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
    2140. 

  2140.  INTEGER,    INTENT(IN   )                            :: RATIO
    2141. 

  2141.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
    2142. 

  2142.  INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
    2143. 

  2143. !LOCAL VARIABLES
    2144. 

  2144.  INTEGER                                              :: I,J
    2145. 

  2145.  INTEGER                                              :: IP
    2146. 

  2146.   IP = MOD(I,RATIO)
    2147. 

  2147.   SELECT CASE(IP)
    2148. 

  2148.    CASE ( 1 )
    2149. 

  2149.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO) - 1
    2150. 

  2150.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
    2151. 

  2151.     VBWGT1(I,J) = 2.0/9.0
    2152. 

  2152.     VBWGT2(I,J) = 2.0/9.0
    2153. 

  2153.     VBWGT3(I,J) = 4.0/9.0
    2154. 

  2154.     VBWGT4(I,J) = 1.0/9.0
    2155. 

  2155.    CASE ( 2 )
    2156. 

  2156.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    2157. 

  2157.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) 
    2158. 

  2158.     VBWGT1(I,J) = 1.0/3.0
    2159. 

  2159.     VBWGT2(I,J) = 0.0
    2160. 

  2160.     VBWGT3(I,J) = 0.0
    2161. 

  2161.     VBWGT4(I,J) = 2.0/3.0
    2162. 

  2162.    CASE ( 0 )
    2163. 

  2163.     IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
    2164. 

  2164.     JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
    2165. 

  2165.     VBWGT1(I,J) = 2.0/3.0
    2166. 

  2166.     VBWGT2(I,J) = 0.0
    2167. 

  2167.     VBWGT3(I,J) = 1.0/3.0
    2168. 

  2168.     VBWGT4(I,J) = 0.0
    2169. 

  2169.    END SELECT
    2170. 

  2170.  RETURN
    2171. 

  2171.  END SUBROUTINE SUB6V
    2172. 

  2172. 

  2173. 

  2174. !------------------------------------------------------------------------------
    2175. 

  2175. !
    2176. 

  2176. SUBROUTINE WEIGTS_CHECK(HBWGT1,HBWGT2,HBWGT3,HBWGT4,       & 
    2177. 

  2177.                         VBWGT1,VBWGT2,VBWGT3,VBWGT4,       &
    2178. 

  2178.                         IDS,IDE,JDS,JDE,KDS,KDE,           &
    2179. 

  2179.                         IMS,IME,JMS,JME,KMS,KME,           & 
    2180. 

  2180.                         ITS,ITE,JTS,JTE,KTS,KTE            )
    2181. 

  2181. 

  2182.   IMPLICIT NONE
    2183. 

  2183.   INTEGER, INTENT(IN)                                 :: IDS,IDE,JDS,JDE,KDS,KDE,  &
    2184. 

  2184.                                                          IMS,IME,JMS,JME,KMS,KME,  &
    2185. 

  2185.                                                          ITS,ITE,JTS,JTE,KTS,KTE
    2186. 

  2186.   REAL,    DIMENSION(IMS:IME,JMS:JME),   INTENT(IN)   :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    2187. 

  2187.   REAL,    DIMENSION(IMS:IME,JMS:JME),   INTENT(IN)   :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
    2188. 

  2188. 

  2189. ! local 
    2190. 

  2190. 

  2191.   REAL , PARAMETER :: EPSI=1.0E-3
    2192. 

  2192.   INTEGER          :: I,J
    2193. 

  2193.   REAL             :: ADDSUM
    2194. 

  2194.  CHARACTER(LEN=255):: message
    2195. 

  2195. 

  2196. !-------------------------------------------------------------------------------------
    2197. 

  2197. 

  2198. ! DUE TO THE NEED FOR HALO EXCHANGES IN PARALLEL RUNS ONE HAS TO ENSURE CONSISTENT 
    2199. 

  2199. ! USAGE OF NUMBER OF PROCESSORS BEFORE ANY FURTHER COMPUTATIONS. WE INTRODUCE THIS
    2200. 

  2200. ! CHECK FIRST
    2201. 

  2201. 

  2202.   IF((ITE-ITS) .LE. 5 .OR. (JTE-JTS) .LE. 5)THEN
    2203. 

  2203.    WRITE(message,*)'ITE-ITS=',ITE-ITS,'JTE-JTS=',JTE-JTS
    2204. 

  2204.    CALL wrf_message(trim(message))
    2205. 

  2205.    CALL wrf_error_fatal ('NESTED DOMAIN:PLEASE OPTIMIZE THE NUMBER OF PROCESSES; TRY SQUARES OF NUMBERS') 
    2206. 

  2206.   ENDIF
    2207. 

  2207. 

  2208. !  
    2209. 

  2209. ! NOW CHECK WEIGHTS
    2210. 

  2210. !
    2211. 

  2211. 

  2212.   ADDSUM=0.
    2213. 

  2213.   DO J = JTS, MIN(JTE,JDE-1)
    2214. 

  2214.    DO I = ITS, MIN(ITE,IDE-1)
    2215. 

  2215.       ADDSUM=HBWGT1(I,J)+HBWGT2(I,J)+HBWGT3(I,J)+HBWGT4(I,J)
    2216. 

  2216.       IF(ABS(1.0-ADDSUM) .GE. EPSI)THEN
    2217. 

  2217.        WRITE(message,*)'I=',I,'J=',J,'WEIGHTS=',HBWGT1(I,J),HBWGT2(I,J),HBWGT3(I,J),HBWGT4(I,J),1-ADDSUM
    2218. 

  2218.        CALL wrf_message(trim(message))
    2219. 

  2219.        CALL wrf_error_fatal ('NESTED DOMAIN:SOMETHING IS WRONG WITH WEIGHTS COMPUTATION AT MASS POINTS') 
    2220. 

  2220.       ENDIF
    2221. 

  2221.    ENDDO
    2222. 

  2222.   ENDDO
    2223. 

  2223. 

  2224.   ADDSUM=0.
    2225. 

  2225.   DO J = JTS, MIN(JTE,JDE-1)
    2226. 

  2226.    DO I = ITS, MIN(ITE,IDE-1)
    2227. 

  2227.       ADDSUM=VBWGT1(I,J)+VBWGT2(I,J)+VBWGT3(I,J)+VBWGT4(I,J)
    2228. 

  2228.       IF(ABS(1.0-ADDSUM) .GE. EPSI)THEN 
    2229. 

  2229.        WRITE(message,*)'I=',I,'J=',J,'WEIGHTS=',VBWGT1(I,J),VBWGT2(I,J),VBWGT3(I,J),VBWGT4(I,J),1-ADDSUM
    2230. 

  2230.        CALL wrf_message(trim(message))
    2231. 

  2231.        CALL wrf_error_fatal ('NESTED DOMAIN:SOMETHING IS WRONG WITH WEIGHTS COMPUTATION AT VELOCITY POINTS')
    2232. 

  2232.       ENDIF
    2233. 

  2233.    ENDDO
    2234. 

  2234.   ENDDO
    2235. 

  2235. 

  2236. END SUBROUTINE WEIGTS_CHECK
    2237. 

  2237. 

  2238. !-----------------------------------------------------------------------------------
    2239. 

  2239. 

  2240. SUBROUTINE BOUNDS_CHECK( IIH,JJH,IIV,JJV,          &
    2241. 

  2241.                          IPOS,JPOS,SHW,            &
    2242. 

  2242.                          IDS,IDE,JDS,JDE,KDS,KDE,  & !
    2243. 

  2243.                          IMS,IME,JMS,JME,KMS,KME,  & ! nested grid configuration
    2244. 

  2244.                          ITS,ITE,JTS,JTE,KTS,KTE   )
    2245. 

  2245. 

  2246.  IMPLICIT NONE
    2247. 

  2247.  INTEGER, INTENT(IN) :: IPOS,JPOS,SHW,            &
    2248. 

  2248.                         IDS,IDE,JDS,JDE,KDS,KDE,  & 
    2249. 

  2249.                         IMS,IME,JMS,JME,KMS,KME,  & 
    2250. 

  2250.                         ITS,ITE,JTS,JTE,KTS,KTE   
    2251. 

  2251. 

  2252.  INTEGER, DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IIH,JJH,IIV,JJV
    2253. 

  2253. 

  2254. ! local variables
    2255. 

  2255. 

  2256.  INTEGER :: I,J
    2257. 

  2257.  CHARACTER(LEN=255)                 :: message
    2258. 

  2258. 

  2259. !***  Gopal       - Initial version 
    2260. 

  2260. !***
    2261. 

  2261. !*** CHECK DOMAIN BOUNDS BEFORE PROCEEDING TO INTERPOLATION
    2262. 

  2262. !
    2263. 

  2263. !============================================================================
    2264. 

  2264. 

  2265.   IF(IPOS .LE. SHW)CALL wrf_error_fatal('NESTED DOMAIN TOO CLOSE TO PARENTs X-BOUNDARY')
    2266. 

  2266.   IF(JPOS .LE. SHW)CALL wrf_error_fatal('NESTED DOMAIN TOO CLOSE TO PARENTs Y-BOUNDARY')
    2267. 

  2267. 

  2268.   DO J = JTS, MIN(JTE,JDE-1)
    2269. 

  2269.    DO I = ITS, MIN(ITE,IDE-1)
    2270. 

  2270.       IF(IIH(I,J) .EQ. 0)CALL wrf_error_fatal ('IIH=0: SOMETHING IS WRONG')
    2271. 

  2271.       IF(JJH(I,J) .EQ. 0)CALL wrf_error_fatal ('JJH=0: SOMETHING IS WRONG')
    2272. 

  2272.    ENDDO
    2273. 

  2273.   ENDDO
    2274. 

  2274. 

  2275.   DO J = JTS, MIN(JTE,JDE-1)
    2276. 

  2276.    DO I = ITS, MIN(ITE,IDE-1)
    2277. 

  2277.       IF(IIH(I,J) .LT. (IPOS-SHW) .OR. JJH(I,J) .LT. (JPOS-SHW) .OR.   &
    2278. 

  2278.          IIV(I,J) .LT. (IPOS-SHW) .OR. JJV(I,J) .LT. (JPOS-SHW))THEN
    2279. 

  2279.          WRITE(message,*)I,J,IIH(I,J),IPOS,JJH(I,J),JPOS,SHW
    2280. 

  2280.          CALL wrf_message(trim(message))
    2281. 

  2281.          WRITE(message,*)I,J,IIV(I,J),IPOS,JJV(I,J),JPOS,SHW
    2282. 

  2282.          CALL wrf_message(trim(message))
    2283. 

  2283.          CALL wrf_error_fatal ('CHECK NESTED DOMAIN BOUNDS: TRY INCREASING STENCIL WIDTH') 
    2284. 

  2284.       ENDIF
    2285. 

  2285.    ENDDO
    2286. 

  2286.   ENDDO
    2287. 

  2287. 

  2288. END SUBROUTINE BOUNDS_CHECK
    2289. 

  2289. 

  2290. !==========================================================================================
    2291. 

  2291. 

  2292. 

  2293. SUBROUTINE BASE_STATE_PARENT ( Z3d,Q3d,T3d,PSTD,        &
    2294. 

  2294.                                PINT,T,Q,CWM,            &
    2295. 

  2295.                                FIS,QS,PD,PDTOP,PTOP,    &
    2296. 

  2296.                                ETA1,ETA2,               &
    2297. 

  2297.                                DETA1,DETA2,             &
    2298. 

  2298.                                IDS,IDE,JDS,JDE,KDS,KDE, &
    2299. 

  2299.                                IMS,IME,JMS,JME,KMS,KME, &
    2300. 

  2300.                                ITS,ITE,JTS,JTE,KTS,KTE  )
    2301. 

  2301. !
    2302. 

  2302. 

  2303.  USE MODULE_MODEL_CONSTANTS
    2304. 

  2304.  IMPLICIT NONE
    2305. 

  2305.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    2306. 

  2306.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    2307. 

  2307.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    2308. 

  2308.  REAL,       INTENT(IN   )                            :: PDTOP,PTOP
    2309. 

  2309.  REAL, DIMENSION(KMS:KME),                 INTENT(IN) :: ETA1,ETA2,DETA1,DETA2
    2310. 

  2310.  REAL, DIMENSION(IMS:IME,JMS:JME),         INTENT(IN) :: FIS,PD,QS
    2311. 

  2311.  REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), INTENT(IN) :: PINT,T,Q,CWM
    2312. 

  2312.  REAL, DIMENSION(KMS:KME),                 INTENT(OUT):: PSTD
    2313. 

  2313.  REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), INTENT(OUT):: Z3d,Q3d,T3d
    2314. 

  2314. 

  2315. ! local
    2316. 

  2316. 

  2317.  INTEGER,PARAMETER                                    :: JTB=134
    2318. 

  2318.  INTEGER                                              :: I,J,K,ILOC,JLOC
    2319. 

  2319.  REAL, PARAMETER                                      :: LAPSR=6.5E-3, GI=1./G,D608=0.608
    2320. 

  2320.  REAL, PARAMETER                                      :: COEF3=287.05*GI*LAPSR, COEF2=-1./COEF3
    2321. 

  2321.  REAL, PARAMETER                                      :: TRG=2.0*R_D*GI,LAPSI=1.0/LAPSR
    2322. 

  2322.  REAL, PARAMETER                                      :: P_REF=103000.
    2323. 

  2323.  REAL                                                 :: A,B,APELP,RTOPP,DZ,ZMID
    2324. 

  2324.  REAL, DIMENSION(IMS:IME,JMS:JME)                     :: SLP,TSFC,ZMSLP
    2325. 

  2325.  REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME)             :: Z3d_IN
    2326. 

  2326.  REAL,DIMENSION(JTB)                                  :: PIN,ZIN,Y2,PIO,ZOUT,DUM1,DUM2
    2327. 

  2327.  REAL,DIMENSION(JTB)                                  :: QIN,QOUT,TIN,TOUT
    2328. 

  2328. !-------------------------------------------------------------------------------------- 
    2329. 

  2329. 

  2330. !  CLEAN Z3D ARRAY FIRST
    2331. 

  2331. 

  2332.     DO K=KDS,KDE
    2333. 

  2333.      DO J = JTS, MIN(JTE,JDE-1)
    2334. 

  2334.       DO I = ITS, MIN(ITE,IDE-1)
    2335. 

  2335.        Z3d(I,J,K)=0.0
    2336. 

  2336.        T3d(I,J,K)=0.0
    2337. 

  2337.        Q3d(I,J,K)=0.0
    2338. 

  2338.       ENDDO
    2339. 

  2339.      ENDDO
    2340. 

  2340.     ENDDO 
    2341. 

  2341. 

  2342. 

  2343. !  DETERMINE THE HEIGHTS ON THE PARENT DOMAIN
    2344. 

  2344. 

  2345.     DO J = JTS, MIN(JTE,JDE-1)
    2346. 

  2346.       DO I = ITS, MIN(ITE,IDE-1)
    2347. 

  2347.        Z3d_IN(I,J,1)=FIS(I,J)*GI
    2348. 

  2348.       ENDDO
    2349. 

  2349.     ENDDO 
    2350. 

  2350. 

  2351.     DO K = KDS,KDE-1
    2352. 

  2352.      DO J = JTS, MIN(JTE,JDE-1)
    2353. 

  2353.       DO I = ITS, MIN(ITE,IDE-1)
    2354. 

  2354.         APELP    = (PINT(I,J,K+1)+PINT(I,J,K))
    2355. 

  2355. !       RTOPP    = TRG*T(I,J,K)*(1.0+Q(I,J,K)*P608-CWM(I,J,K))/APELP
    2356. 

  2356.         RTOPP    = TRG*T(I,J,K)*(1.0+Q(I,J,K)*P608)/APELP
    2357. 

  2357.         DZ       = RTOPP*(DETA1(K)*PDTOP+DETA2(K)*PD(I,J))   ! (RTv/P_TOT)*D(P_HYDRO)
    2358. 

  2358.         Z3d_IN(I,J,K+1) = Z3d_IN(I,J,K) + DZ
    2359. 

  2359.       ENDDO
    2360. 

  2360.      ENDDO
    2361. 

  2361.     ENDDO
    2362. 

  2362. 

  2363. 

  2364. !  CONSTRUCT STANDARD ISOBARIC SURFACES 
    2365. 

  2365. 

  2366.     DO K=KDS,KDE                         ! target points in model interface levels (pint)
    2367. 

  2367.        PSTD(K) = ETA1(K)*PDTOP + ETA2(K)*(P_REF -PDTOP - PTOP) + PTOP
    2368. 

  2368.     ENDDO
    2369. 

  2369. 

  2370. !   DETERMINE THE MSLP USE THAT TO CREATE HEIGHTS AT 1000. mb LEVEL. THESE HEIGHTS  
    2371. 

  2371. !   MAY ONLY BE USED IN VERTICAL INTERPOLATION TO ISOBARIC SURFACES WHICH ARE LOCATED
    2372. 

  2372. !   BELOW GROUND LEVEL. 
    2373. 

  2373. 

  2374.     DO J = JTS, MIN(JTE,JDE-1)
    2375. 

  2375.       DO I = ITS, MIN(ITE,IDE-1)
    2376. 

  2376.         TSFC(I,J) = T(I,J,1)*(1.+D608*Q(I,J,1)) + LAPSR*(Z3d_IN(I,J,1)+Z3d_IN(I,J,2))*0.5
    2377. 

  2377.         A         = LAPSR*Z3d_IN(I,J,1)/TSFC(I,J)
    2378. 

  2378.         SLP(I,J)  = PINT(I,J,1)*(1-A)**COEF2    ! sea level pressure 
    2379. 

  2379.         B         = (PSTD(1)/SLP(I,J))**COEF3
    2380. 

  2380.         ZMSLP(I,J)= TSFC(I,J)*LAPSI*(1.0 - B)   ! Height at 1000. mb level
    2381. 

  2381.       ENDDO
    2382. 

  2382.     ENDDO
    2383. 

  2383. 

  2384. !   INTERPOLATE Z3d_IN TO STANDARD PRESSURE INTERFACES. FOR LEVELS BELOW
    2385. 

  2385. !   GROUND USE ZMSLP(I,J)
    2386. 

  2386. 

  2387.     DO J = JTS, MIN(JTE,JDE-1)
    2388. 

  2388.       DO I = ITS, MIN(ITE,IDE-1)
    2389. 

  2389. !    
    2390. 

  2390. !     clean local array before use of spline
    2391. 

  2391. 

  2392.       PIN=0.;ZIN=0.;Y2=0;PIO=0.;ZOUT=0.;DUM1=0.;DUM2=0.
    2393. 

  2393. 

  2394.        DO K=KDS,KDE                           ! inputs at model interfaces 
    2395. 

  2395.          PIN(K) = PINT(I,J,KDE-K+1)
    2396. 

  2396.          ZIN(K) = Z3d_IN(I,J,KDE-K+1)
    2397. 

  2397.        ENDDO
    2398. 

  2398. 

  2399.        IF(PINT(I,J,1) .LE. PSTD(1))THEN
    2400. 

  2400.           PIN(KDE) = PSTD(1)
    2401. 

  2401.           ZIN(KDE) = ZMSLP(I,J)
    2402. 

  2402.        ENDIF
    2403. 

  2403. !
    2404. 

  2404.        Y2(1  )=0.
    2405. 

  2405.        Y2(KDE)=0.
    2406. 

  2406. !
    2407. 

  2407.        DO K=KDS,KDE
    2408. 

  2408.           PIO(K)=PSTD(K)
    2409. 

  2409.        ENDDO
    2410. 

  2410. !
    2411. 

  2411.        CALL SPLINE1(I,J,JTB,KDE,PIN,ZIN,Y2,KDE,PIO,ZOUT,DUM1,DUM2)  ! interpolate
    2412. 

  2412. !
    2413. 

  2413. 

  2414.        DO K=KDS,KDE                           ! inputs at model interfaces
    2415. 

  2415.          Z3d(I,J,K)=ZOUT(K)
    2416. 

  2416.        ENDDO
    2417. 

  2417. 

  2418.       ENDDO
    2419. 

  2419.     ENDDO
    2420. 

  2420. !
    2421. 

  2421. !   INTERPOLATE TEMPERATURE ONTO THE STANDARD PRESSURE LEVELS. FOR LEVELS BELOW  
    2422. 

  2422. !   GROUND USE A LAPSE RATE ATMOSPHERE 
    2423. 

  2423. !
    2424. 

  2424.     DO J = JTS, MIN(JTE,JDE-1)
    2425. 

  2425.       DO I = ITS, MIN(ITE,IDE-1)
    2426. 

  2426. !  
    2427. 

  2427. !     clean local array before use of spline or linear interpolation
    2428. 

  2428. !
    2429. 

  2429.       PIN=0.;TIN=0.;Y2=0;PIO=0.;TOUT=0.;DUM1=0.;DUM2=0.
    2430. 

  2430. 

  2431.        DO K=KDS+1,KDE                           ! inputs at model levels
    2432. 

  2432.          PIN(K-1) = EXP((ALOG(PINT(I,J,KDE-K+1))+ALOG(PINT(I,J,KDE-K+2)))*0.5)
    2433. 

  2433.          TIN(K-1) = T(I,J,KDE-K+1)
    2434. 

  2434.        ENDDO
    2435. 

  2435. 

  2436.        IF(PINT(I,J,1) .LE. PSTD(1))THEN
    2437. 

  2437.          PIN(KDE-1) = EXP((ALOG(PSTD(1))+ALOG(PSTD(2)))*0.5)
    2438. 

  2438.          ZMID     = 0.5*(Z3d_IN(I,J,1)+Z3d_IN(I,J,2))
    2439. 

  2439.          TIN(KDE-1) = T(I,J,1) + LAPSR*(ZMID-ZMSLP(I,J))
    2440. 

  2440.        ENDIF
    2441. 

  2441. !
    2442. 

  2442.        Y2(1    )=0.
    2443. 

  2443.        Y2(KDE-1)=0.
    2444. 

  2444. !
    2445. 

  2445.        DO K=KDS,KDE-1
    2446. 

  2446.           PIO(K)=EXP((ALOG(PSTD(K))+ALOG(PSTD(K+1)))*0.5)
    2447. 

  2447.        ENDDO
    2448. 

  2448. 

  2449.        CALL SPLINE1(I,J,JTB,KDE-1,PIN,TIN,Y2,KDE-1,PIO,TOUT,DUM1,DUM2)  ! interpolate
    2450. 

  2450. 

  2451. 

  2452.        DO K=KDS,KDE-1                           ! inputs at model levels
    2453. 

  2453.          T3d(I,J,K)=TOUT(K)
    2454. 

  2454.        ENDDO
    2455. 

  2455. 

  2456.       ENDDO
    2457. 

  2457.     ENDDO
    2458. 

  2458. 

  2459. !
    2460. 

  2460. !   INTERPOLATE MOISTURE ONTO THE STANDARD PRESSURE LEVELS. FOR LEVELS BELOW 
    2461. 

  2461. !   GROUND USE THE SURFACE MOISTURE 
    2462. 

  2462. !
    2463. 

  2463.     DO J = JTS, MIN(JTE,JDE-1)
    2464. 

  2464.       DO I = ITS, MIN(ITE,IDE-1)
    2465. 

  2465. !
    2466. 

  2466. !     clean local array before use of spline or linear interpolation
    2467. 

  2467. 

  2468. 

  2469.       PIN=0.;QIN=0.;Y2=0;PIO=0.;QOUT=0.;DUM1=0.;DUM2=0.
    2470. 

  2470. 

  2471.        DO K=KDS+1,KDE                           ! inputs at model levels
    2472. 

  2472.          PIN(K-1) = EXP((ALOG(PINT(I,J,KDE-K+1))+ALOG(PINT(I,J,KDE-K+2)))*0.5)
    2473. 

  2473.          QIN(K-1) = Q(I,J,KDE-K+1)
    2474. 

  2474.        ENDDO
    2475. 

  2475. 

  2476.        IF(PINT(I,J,1) .LE. PSTD(1))THEN
    2477. 

  2477.           PIN(KDE-1) = EXP((ALOG(PSTD(1))+ALOG(PSTD(2)))*0.5)
    2478. 

  2478. !         QIN(KDE-1) =  QS(I,J)
    2479. 

  2479.        ENDIF
    2480. 

  2480. 

  2481.        Y2(1    )=0.
    2482. 

  2482.        Y2(KDE-1)=0.
    2483. 

  2483. !
    2484. 

  2484.        DO K=KDS,KDE-1
    2485. 

  2485.           PIO(K)=EXP((ALOG(PSTD(K))+ALOG(PSTD(K+1)))*0.5)
    2486. 

  2486.        ENDDO
    2487. 

  2487. 

  2488.        CALL SPLINE1(I,J,JTB,KDE-1,PIN,QIN,Y2,KDE-1,PIO,QOUT,DUM1,DUM2)  ! interpolate
    2489. 

  2489. 

  2490.        DO K=KDS,KDE-1                          ! inputs at model levels
    2491. 

  2491.          Q3d(I,J,K)=QOUT(K)
    2492. 

  2492.        ENDDO
    2493. 

  2493. 

  2494.       ENDDO
    2495. 

  2495.     ENDDO
    2496. 

  2496. 

  2497. END SUBROUTINE BASE_STATE_PARENT
    2498. 

  2498. !=============================================================================
    2499. 

  2499.       SUBROUTINE SPLINE1(I,J,JTBX,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q)
    2500. 

  2500. !
    2501. 

  2501. !   ******************************************************************
    2502. 

  2502. !   *                                                                *
    2503. 

  2503. !   *  THIS IS A ONE-DIMENSIONAL CUBIC SPLINE FITTING ROUTINE        *
    2504. 

  2504. !   *  PROGRAMED FOR A SMALL SCALAR MACHINE.                         *
    2505. 

  2505. !   *                                                                *
    2506. 

  2506. !   *  PROGRAMER Z. JANJIC                                           *
    2507. 

  2507. !   *                                                                *
    2508. 

  2508. !   *  NOLD - NUMBER OF GIVEN VALUES OF THE FUNCTION.  MUST BE GE 3. *
    2509. 

  2509. !   *  XOLD - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE     *
    2510. 

  2510. !   *         FUNCTION ARE GIVEN.  MUST BE IN ASCENDING ORDER.       *
    2511. 

  2511. !   *  YOLD - THE GIVEN VALUES OF THE FUNCTION AT THE POINTS XOLD.   *
    2512. 

  2512. !   *  Y2   - THE SECOND DERIVATIVES AT THE POINTS XOLD.  IF NATURAL *
    2513. 

  2513. !   *         SPLINE IS FITTED Y2(1)=0. AND Y2(NOLD)=0. MUST BE      *
    2514. 

  2514. !   *         SPECIFIED.                                             *
    2515. 

  2515. !   *  NNEW - NUMBER OF VALUES OF THE FUNCTION TO BE CALCULATED.     *
    2516. 

  2516. !   *  XNEW - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE     *
    2517. 

  2517. !   *         FUNCTION ARE CALCULATED.  XNEW(K) MUST BE GE XOLD(1)   *
    2518. 

  2518. !   *         AND LE XOLD(NOLD).                                     *
    2519. 

  2519. !   *  YNEW - THE VALUES OF THE FUNCTION TO BE CALCULATED.           *
    2520. 

  2520. !   *  P, Q - AUXILIARY VECTORS OF THE LENGTH NOLD-2.                *
    2521. 

  2521. !   *                                                                *
    2522. 

  2522. !   ******************************************************************
    2523. 

  2523. !---------------------------------------------------------------------
    2524. 

  2524.       IMPLICIT NONE
    2525. 

  2525. !---------------------------------------------------------------------
    2526. 

  2526.       INTEGER,INTENT(IN) :: I,J,JTBX,NNEW,NOLD
    2527. 

  2527.       REAL,DIMENSION(JTBX),INTENT(IN) :: XNEW,XOLD,YOLD
    2528. 

  2528.       REAL,DIMENSION(JTBX),INTENT(INOUT) :: P,Q,Y2
    2529. 

  2529.       REAL,DIMENSION(JTBX),INTENT(OUT) :: YNEW
    2530. 

  2530. !
    2531. 

  2531.       INTEGER :: II,JJ,K,K1,K2,KOLD,NOLDM1
    2532. 

  2532.       REAL :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR                 &
    2533. 

  2533.              ,RDX,RTDXC,X,XK,XSQ,Y2K,Y2KP1
    2534. 

  2534.       CHARACTER(LEN=255) :: message
    2535. 

  2535. !---------------------------------------------------------------------
    2536. 

  2536. 

  2537. !     debug
    2538. 

  2538. 

  2539.       II=9999 !67 !35 !50   !4
    2540. 

  2540.       JJ=9999 !31 !73 !115  !192
    2541. 

  2541. #if defined(EXPENSIVE_HWRF_DEBUG_STUFF)
    2542. 

  2542.       IF(I.eq.II.and.J.eq.JJ)THEN
    2543. 

  2543.         WRITE(message,*)'DEBUG in SPLINE1:HSO= ',xnew(1:nold)
    2544. 

  2544.         CALL wrf_debug(1,trim(message))
    2545. 

  2545.         DO K=1,NOLD
    2546. 

  2546.          WRITE(message,*)'DEBUG in SPLINE1:L,ZETAI,PINTI= ' &
    2547. 

  2547.                         ,K,YOLD(K),XOLD(K)
    2548. 

  2548.          CALL wrf_debug(1,trim(message))
    2549. 

  2549.         ENDDO 
    2550. 

  2550.       ENDIF 
    2551. 

  2551. #endif
    2552. 

  2552. 

  2553. !
    2554. 

  2554.       NOLDM1=NOLD-1
    2555. 

  2555. !
    2556. 

  2556.       DXL=XOLD(2)-XOLD(1)
    2557. 

  2557.       DXR=XOLD(3)-XOLD(2)
    2558. 

  2558.       DYDXL=(YOLD(2)-YOLD(1))/DXL
    2559. 

  2559.       DYDXR=(YOLD(3)-YOLD(2))/DXR
    2560. 

  2560.       RTDXC=0.5/(DXL+DXR)
    2561. 

  2561. !
    2562. 

  2562.       P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1))
    2563. 

  2563.       Q(1)=-RTDXC*DXR
    2564. 

  2564. !
    2565. 

  2565.       IF(NOLD.EQ.3)GO TO 150
    2566. 

  2566. !---------------------------------------------------------------------
    2567. 

  2567.       K=3
    2568. 

  2568. !
    2569. 

  2569.   100 DXL=DXR
    2570. 

  2570.       DYDXL=DYDXR
    2571. 

  2571.       DXR=XOLD(K+1)-XOLD(K)
    2572. 

  2572.       DYDXR=(YOLD(K+1)-YOLD(K))/DXR
    2573. 

  2573.       DXC=DXL+DXR
    2574. 

  2574.       DEN=1./(DXL*Q(K-2)+DXC+DXC)
    2575. 

  2575. !
    2576. 

  2576.       P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2))
    2577. 

  2577.       Q(K-1)=-DEN*DXR
    2578. 

  2578. !
    2579. 

  2579.       K=K+1
    2580. 

  2580.       IF(K.LT.NOLD)GO TO 100
    2581. 

  2581. !-----------------------------------------------------------------------
    2582. 

  2582.   150 K=NOLDM1
    2583. 

  2583. !
    2584. 

  2584.   200 Y2(K)=P(K-1)+Q(K-1)*Y2(K+1)
    2585. 

  2585. !
    2586. 

  2586.       K=K-1
    2587. 

  2587.       IF(K.GT.1)GO TO 200
    2588. 

  2588. !-----------------------------------------------------------------------
    2589. 

  2589.       K1=1
    2590. 

  2590. !
    2591. 

  2591.   300 XK=XNEW(K1)
    2592. 

  2592. !
    2593. 

  2593.       DO 400 K2=2,NOLD
    2594. 

  2594. !
    2595. 

  2595.       IF(XOLD(K2).GT.XK)THEN
    2596. 

  2596.         KOLD=K2-1
    2597. 

  2597.         GO TO 450
    2598. 

  2598.       ENDIF
    2599. 

  2599. !
    2600. 

  2600.   400 CONTINUE
    2601. 

  2601. !
    2602. 

  2602.       YNEW(K1)=YOLD(NOLD)
    2603. 

  2603.       GO TO 600
    2604. 

  2604. !
    2605. 

  2605.   450 IF(K1.EQ.1)GO TO 500
    2606. 

  2606.       IF(K.EQ.KOLD)GO TO 550
    2607. 

  2607. !
    2608. 

  2608.   500 K=KOLD
    2609. 

  2609. !
    2610. 

  2610.       Y2K=Y2(K)
    2611. 

  2611.       Y2KP1=Y2(K+1)
    2612. 

  2612.       DX=XOLD(K+1)-XOLD(K)
    2613. 

  2613.       RDX=1./DX
    2614. 

  2614. !
    2615. 

  2615.       AK=.1666667*RDX*(Y2KP1-Y2K)
    2616. 

  2616.       BK=0.5*Y2K
    2617. 

  2617.       CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K)
    2618. 

  2618. !
    2619. 

  2619.   550 X=XK-XOLD(K)
    2620. 

  2620.       XSQ=X*X
    2621. 

  2621. !
    2622. 

  2622.       YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K)
    2623. 

  2623. 

  2624. !  debug
    2625. 

  2625. 

  2626. #if defined(EXPENSIVE_HWRF_DEBUG_STUFF)
    2627. 

  2627.       if(i.eq.ii.and.j.eq.jj)then
    2628. 

  2628.         write(message,*) 'DEBUG:: k1,xnew(k1),ynew(k1): ', k1,xnew(k1),ynew(k1)
    2629. 

  2629.         CALL wrf_debug(1,trim(message))
    2630. 

  2630.       endif
    2631. 

  2631. #endif
    2632. 

  2632. 

  2633. !
    2634. 

  2634.   600 K1=K1+1
    2635. 

  2635.       IF(K1.LE.NNEW)GO TO 300
    2636. 

  2636. 

  2637.       RETURN
    2638. 

  2638.       END SUBROUTINE SPLINE1
    2639. 

  2639. !---------------------------------------------------------------------
    2640. 

  2640. 

  2641. SUBROUTINE NEST_TERRAIN ( nest, config_flags )
    2642. 

  2642. 

  2643.  USE module_domain
    2644. 

  2644.  USE module_configure
    2645. 

  2645.  USE module_timing
    2646. 

  2646.  USE module_TERRAIN
    2647. 

  2647.  USE wrfsi_static
    2648. 

  2648.  USE module_SMOOTH_TERRAIN
    2649. 

  2649. 

  2650.  IMPLICIT NONE
    2651. 

  2651. 

  2652.  TYPE(domain) , POINTER                        :: nest
    2653. 

  2653.  TYPE(grid_config_rec_type) , INTENT(IN)       :: config_flags
    2654. 

  2654. 

  2655. !
    2656. 

  2656. ! Local variables
    2657. 

  2657. !
    2658. 

  2658. 

  2659.  LOGICAL, EXTERNAL                 :: wrf_dm_on_monitor
    2660. 

  2660.  INTEGER                           :: ids,ide,jds,jde,kds,kde
    2661. 

  2661.  INTEGER                           :: ims,ime,jms,jme,kms,kme
    2662. 

  2662.  INTEGER                           :: its,ite,jts,jte,kts,kte 
    2663. 

  2663.  INTEGER                           :: i_parent_start, j_parent_start
    2664. 

  2664.  INTEGER                           :: parent_grid_ratio
    2665. 

  2665.  INTEGER                           :: n,i,j,ii,jj,nnxp,nnyp
    2666. 

  2666.  INTEGER                           :: i_start,j_start,level
    2667. 

  2667.  REAL, DIMENSION(1,1), TARGET      :: nothing
    2668. 

  2668.  REAL                              :: lah_nest_11, loh_nest_11
    2669. 

  2669.  INTEGER                           :: im_big, jm_big, i_add
    2670. 

  2670.  INTEGER                           :: im, jm
    2671. 

  2671.  CHARACTER(LEN=6)                  :: nestpath
    2672. 

  2672. 

  2673.  integer                           :: input_type
    2674. 

  2674.  character(len=128)                :: input_fname
    2675. 

  2675.  character (len=32)                :: cname
    2676. 

  2676.  integer                           :: ndim
    2677. 

  2677.  character (len=3)                 :: memorder
    2678. 

  2678.  character (len=32)                :: stagger
    2679. 

  2679.  integer, dimension(3)             :: domain_start, domain_end
    2680. 

  2680.  integer                           :: wrftype
    2681. 

  2681.  character (len=128), dimension(3) :: dimnames
    2682. 

  2682. 

  2683.  integer :: istatus
    2684. 

  2684.  integer :: handle
    2685. 

  2685.  integer :: comm_1, comm_2
    2686. 

  2686. 

  2687.  real, allocatable, dimension(:,:,:) :: real_domain
    2688. 

  2688. 

  2689.  character (len=10), dimension(24)  :: name = (/ "XLAT_M    ", &
    2690. 

  2690.                                                 "XLONG_M   ", &
    2691. 

  2691.                                                 "XLAT_V    ", &
    2692. 

  2692.                                                 "XLONG_V   ", &
    2693. 

  2693.                                                 "E         ", &
    2694. 

  2694.                                                 "F         ", &
    2695. 

  2695.                                                 "LANDMASK  ", &
    2696. 

  2696.                                                 "LANDUSEF  ", &
    2697. 

  2697.                                                 "LU_INDEX  ", &
    2698. 

  2698.                                                 "HCNVX     ", &
    2699. 

  2699.                                                 "HSTDV     ", &
    2700. 

  2700.                                                 "HASYW     ", &
    2701. 

  2701.                                                 "HASYS     ", &
    2702. 

  2702.                                                 "HASYSW    ", &
    2703. 

  2703.                                                 "HASYNW    ", &
    2704. 

  2704.                                                 "HLENW     ", &
    2705. 

  2705.                                                 "HLENS     ", &
    2706. 

  2706.                                                 "HLENSW    ", &
    2707. 

  2707.                                                 "HLENNW    ", &
    2708. 

  2708.                                                 "HANIS     ", &
    2709. 

  2709.                                                 "HSLOP     ", &
    2710. 

  2710.                                                 "HANGL     ", &
    2711. 

  2711.                                                 "HZMAX     ", & 
    2712. 

  2712.                                                 "HGT_M     " /)
    2713. 

  2713. 

  2714.  integer, parameter :: IO_BIN=1, IO_NET=2
    2715. 

  2715. 

  2716.  integer :: io_form_input
    2717. 

  2717.  integer :: itsok,iteok,jtsok,jteok
    2718. 

  2718. 

  2719.  CHARACTER(LEN=512) :: message
    2720. 

  2720. 

  2721.  write(message,'("Nest d",I2," entering nest_terrain")') nest%id
    2722. 

  2722.  call wrf_debug(1,trim(message))
    2723. 

  2723. 

  2724.  call START_TIMING()
    2725. 

  2725. 

  2726.  write(message,*)"in NEST_TERRAIN config_flags%io_form_input = ", config_flags%io_form_input
    2727. 

  2727.  CALL wrf_debug(2,trim(message))
    2728. 

  2728.  write(message,*)"in NEST_TERRAIN config_flags%auxinput1_inname = ", config_flags%auxinput1_inname
    2729. 

  2729.  CALL wrf_debug(2,trim(message))
    2730. 

  2730. 

  2731.  io_form_input = config_flags%io_form_input
    2732. 

  2732.  if (config_flags%auxinput1_inname(1:7) == "met_nmm") then
    2733. 

  2733.     input_type = 2
    2734. 

  2734.  else
    2735. 

  2735.     input_type = 1
    2736. 

  2736.  end if
    2737. 

  2737. 

  2738. !----------------------------------------------------------------------------------
    2739. 

  2739. 

  2740.       IDS = nest%sd31
    2741. 

  2741.       IDE = nest%ed31
    2742. 

  2742.       JDS = nest%sd32
    2743. 

  2743.       JDE = nest%ed32
    2744. 

  2744.       KDS = nest%sd33
    2745. 

  2745.       KDE = nest%ed33
    2746. 

  2746. 

  2747.       IMS = nest%sm31
    2748. 

  2748.       IME = nest%em31
    2749. 

  2749.       JMS = nest%sm32
    2750. 

  2750.       JME = nest%em32
    2751. 

  2751.       KMS = nest%sm33
    2752. 

  2752.       KME = nest%em33
    2753. 

  2753. 

  2754.       ITS = nest%sp31
    2755. 

  2755.       ITE = nest%ep31
    2756. 

  2756.       JTS = nest%sp32
    2757. 

  2757.       JTE = nest%ep32
    2758. 

  2758.       KTS = nest%sp33
    2759. 

  2759.       KTE = nest%ep33
    2760. 

  2760. 

  2761.       i_parent_start = nest%i_parent_start
    2762. 

  2762.       j_parent_start = nest%j_parent_start
    2763. 

  2763.       parent_grid_ratio = nest%parent_grid_ratio
    2764. 

  2764. 

  2765.       NNXP=IDE-1
    2766. 

  2766.       NNYP=JDE-1
    2767. 

  2767.       im = NNXP
    2768. 

  2768.       jm = NNYP
    2769. 

  2769. 

  2770.        ! Find nesting depth:
    2771. 

  2771.        call find_ijstart_level (nest,i_start,j_start,level)
    2772. 

  2772.        write(message,*)" nest%id =", nest%id , " i_start,j_start,level =", i_start,j_start,level
    2773. 

  2773.        CALL wrf_debug(2,trim(message))
    2774. 

  2774.        if ( level <= 0 ) then
    2775. 

  2775.           CALL wrf_error_fatal('this routine NEST_TERRAIN should not be called for top-level domain')
    2776. 

  2776.        end if
    2777. 

  2777. 

  2778.       ! Monitor process stores high-resolution topography:
    2779. 

  2779. #ifdef DM_PARALLEL
    2780. 

  2780.       monitor_only: IF ( wrf_dm_on_monitor() ) THEN
    2781. 

  2781. #endif
    2782. 

  2782.          call wrf_debug(1,'NEST_TERRAIN MASTER PROCESS')
    2783. 

  2783.          call MASTER(IDS,IDE,JDS,JDE)
    2784. 

  2784. #ifdef DM_PARALLEL
    2785. 

  2785.       ELSE
    2786. 

  2786.          call wrf_debug(1,'NEST_TERRAIN SLAVE PROCESS')
    2787. 

  2787.          call SLAVE(IDS,IDE,JDS,JDE)
    2788. 

  2788.       ENDIF monitor_only
    2789. 

  2789. #endif
    2790. 

  2790. 

  2791.       if(config_flags%terrain_smoothing==2) then     
    2792. 

  2792.          call wrf_debug(1,'Call fast smoother (smooth_terrain)')
    2793. 

  2793.          call smooth_terrain(nest,12,12, &
    2794. 

  2794.               IDS,IDE,JDS,JDE,KDS,KDE, &
    2795. 

  2795.               IMS,IME,JMS,JME,KMS,KME, &
    2796. 

  2796.               ITS,ITE,JTS,JTE,KTS,KTE)
    2797. 

  2797.       elseif(config_flags%terrain_smoothing==1) then
    2798. 

  2798.          continue ! already handled this case in the call to MASTER
    2799. 

  2799.       elseif(config_flags%terrain_smoothing==0) then
    2800. 

  2800.          call wrf_debug(1,'Terrain smoothing is disabled.')
    2801. 

  2801.       else
    2802. 

  2802.          write(message,*) 'Invalid option for terrain_smoothing: ',config_flags%terrain_smoothing
    2803. 

  2803.          call wrf_error_fatal(message)
    2804. 

  2804.       endif
    2805. 

  2805. 

  2806.      DO J = jts,jte
    2807. 

  2807.         DO I = its,ite
    2808. 

  2808. #ifdef IDEAL_NMM_TC
    2809. 

  2809.            nest%hres_fis(I,J)= 0.0 ! idealized
    2810. 

  2810. #else
    2811. 

  2811.            nest%hres_fis(i,j)=9.81*nest%hres_avc(i,j)
    2812. 

  2812. #endif
    2813. 

  2813.         ENDDO
    2814. 

  2814.      ENDDO
    2815. 

  2815. 

  2816.      write(message,'("Nest d",I0," nest_terrain")') nest%id
    2817. 

  2817.      call END_TIMING(trim(message))
    2818. 

  2818. 

  2819. CONTAINS
    2820. 

  2820. #ifdef DM_PARALLEL
    2821. 

  2821.   SUBROUTINE SLAVE(IDS,IDE,JDS,JDE)
    2822. 

  2822.     IMPLICIT NONE
    2823. 

  2823.     integer, intent(in) :: IDS,IDE,JDS,JDE
    2824. 

  2824.     REAL, DIMENSION(1,1) :: avc_nest,lnd_nest
    2825. 

  2825. 

  2826.      call wrf_debug(1,'call wrf_global_to_patch_real in nest_terrain')
    2827. 

  2827.      call wrf_global_to_patch_real(avc_nest,nest%hres_avc,nest%domdesc,'z','xy', &
    2828. 

  2828.                                    ids,   ide-1, jds,   jde-1, 1, 1, &
    2829. 

  2829.                                    ims,   ime,   jms,   jme,   1, 1, &
    2830. 

  2830.                                    its,   ite,   jts,   jte,   1, 1)
    2831. 

  2831.      call wrf_global_to_patch_real(lnd_nest,nest%hres_lnd,nest%domdesc,'z','xy', &
    2832. 

  2832.                                    ids,   ide-1, jds,   jde-1, 1, 1, &
    2833. 

  2833.                                    ims,   ime,   jms,   jme,   1, 1, &
    2834. 

  2834.                                    its,   ite,   jts,   jte,   1, 1)
    2835. 

  2835.      call wrf_debug(1,'back from wrf_global_to_patch_real in nest_terrain')
    2836. 

  2836. 

  2837. 

  2838.   END SUBROUTINE SLAVE
    2839. 

  2839. #endif
    2840. 

  2840.   SUBROUTINE MASTER(IDS,IDE,JDS,JDE)
    2841. 

  2841.     IMPLICIT NONE
    2842. 

  2842.     integer, intent(in) :: IDS,IDE,JDS,JDE
    2843. 

  2843.     REAL, DIMENSION(IDS:IDE,JDS:JDE)     :: avc_nest, lnd_nest
    2844. 

  2844.     type(nmm_terrain), pointer :: tr
    2845. 

  2845. 

  2846.     nullify(tr)
    2847. 

  2847.     avc_nest = 0.0
    2848. 

  2848.     lnd_nest = 0.0
    2849. 

  2849.     
    2850. 

  2850.     tr=>terrain_for(level,input_type,io_form_input)
    2851. 

  2851. 

  2852.     ! select subdomain from big fine grid
    2853. 

  2853.     i_add = mod(j_start+1,2) 
    2854. 

  2854.     DO j=1,jde
    2855. 

  2855.        DO i=1,ide
    2856. 

  2856.           avc_nest(i,j) = tr%avc(i_start+i-1 + mod(j+1,2)*i_add, j_start+j-1)
    2857. 

  2857.           lnd_nest(i,j) = tr%lnd(i_start+i-1 + mod(j+1,2)*i_add, j_start+j-1)
    2858. 

  2858.        END DO
    2859. 

  2859.     END DO
    2860. 

  2860. 

  2861.     i=1 ; j=1
    2862. 

  2862.     lah_nest_11 = tr%lah(i_start+i-1 + mod(j+1,2)*i_add, j_start+j-1)
    2863. 

  2863.     loh_nest_11 = tr%loh(i_start+i-1 + mod(j+1,2)*i_add, j_start+j-1)
    2864. 

  2864. 

  2865.     IF(ABS(lah_nest_11-nest%HLAT(1,1)) .GE. 0.5 .OR.  & 
    2866. 

  2866.          ABS(loh_nest_11-nest%HLON(1,1)) .GE. 0.5)THEN 
    2867. 

  2867. 

  2868.        WRITE(message,*)'SOME MATCHING TEST i_parent_start, j_parent_start',i_parent_start,j_parent_start
    2869. 

  2869.        CALL wrf_message(trim(message))
    2870. 

  2870.        CALL wrf_message('WRFSI LAT      COMPUTED LAT')
    2871. 

  2871.        WRITE(message,*)lah_nest_11,nest%HLAT(1,1)
    2872. 

  2872.        CALL wrf_message(trim(message))
    2873. 

  2873.        CALL wrf_message('WRFSI LON      COMPUTED LON')
    2874. 

  2874.        WRITE(message,*)loh_nest_11,nest%HLON(1,1)
    2875. 

  2875.        CALL wrf_message(trim(message))
    2876. 

  2876. 

  2877.        CALL wrf_message('CHECK WRFSI CONFIGURATION AND INPUT HIGH RESOLUTION TOPOGRAPHY AND/OR GRID RATIO') 
    2878. 

  2878. #ifndef IDEAL_NMM_TC
    2879. 

  2879.        CALL wrf_error_fatal('LATLON MISMATCH: ERROR READING static FILE FOR THE NEST')
    2880. 

  2880. #endif
    2881. 

  2881.     ENDIF
    2882. 

  2882. 

  2883.     if(config_flags%terrain_smoothing==1) then
    2884. 

  2884.        call wrf_debug(1,'Call slow smoother (smdhld).')
    2885. 

  2885.        call smdhld(ids,ide,jds,jde,avc_nest,lnd_nest,12,12)
    2886. 

  2886.     endif
    2887. 

  2887. 

  2888. #ifdef DM_PARALLEL
    2889. 

  2889.     call wrf_debug(1,'call wrf_global_to_patch_real in nest_terrain')
    2890. 

  2890.     call wrf_global_to_patch_real(avc_nest,nest%hres_avc,nest%domdesc,'z','xy', &
    2891. 

  2891.                                   ids,   ide-1, jds,   jde-1, 1, 1, &
    2892. 

  2892.                                   ims,   ime,   jms,   jme,   1, 1, &
    2893. 

  2893.                                   its,   ite,   jts,   jte,   1, 1)
    2894. 

  2894.     call wrf_global_to_patch_real(lnd_nest,nest%hres_lnd,nest%domdesc,'z','xy', &
    2895. 

  2895.                                   ids,   ide-1, jds,   jde-1, 1, 1, &
    2896. 

  2896.                                   ims,   ime,   jms,   jme,   1, 1, &
    2897. 

  2897.                                   its,   ite,   jts,   jte,   1, 1)
    2898. 

  2898.     call wrf_debug(1,'back from wrf_global_to_patch_real in nest_terrain')
    2899. 

  2899. #endif
    2900. 

  2900.   END SUBROUTINE MASTER
    2901. 

  2901.      
    2902. 

  2902. END SUBROUTINE NEST_TERRAIN
    2903. 

  2903. 

  2904. 

  2905. !===========================================================================================
    2906. 

  2906. 

  2907. 

  2908. SUBROUTINE med_init_domain_constants_nmm ( parent, nest)   !, config_flags)
    2909. 

  2909.   ! Driver layer
    2910. 

  2910.    USE module_domain
    2911. 

  2911.    USE module_configure
    2912. 

  2912.    USE module_timing
    2913. 

  2913.    IMPLICIT NONE
    2914. 

  2914.    TYPE(domain) , POINTER                     :: parent, nest, grid
    2915. 

  2915. !
    2916. 

  2916. !
    2917. 

  2917.    INTERFACE
    2918. 

  2918.      SUBROUTINE med_initialize_nest_nmm ( grid  &   
    2919. 

  2919. !
    2920. 

  2920. # include <dummy_new_args.inc>
    2921. 

  2921. !
    2922. 

  2922.                            )
    2923. 

  2923.         USE module_domain
    2924. 

  2924.         USE module_configure
    2925. 

  2925.         USE module_timing
    2926. 

  2926.         IMPLICIT NONE
    2927. 

  2927.         TYPE(domain) , POINTER                  :: grid
    2928. 

  2928. #include <dummy_new_decl.inc>
    2929. 

  2929.      END SUBROUTINE med_initialize_nest_nmm 
    2930. 

  2930.    END INTERFACE
    2931. 

  2931. 

  2932. !------------------------------------------------------------------------------
    2933. 

  2933. !  PURPOSE: 
    2934. 

  2934. !         - initialize some data, mainly 2D & 3D nmm arrays  very similar to 
    2935. 

  2935. !           those done in ./dyn_nmm/module_initialize_real.f 
    2936. 

  2936. !-----------------------------------------------------------------------------
    2937. 

  2937. !
    2938. 

  2938. 

  2939.    grid => nest
    2940. 

  2940. 

  2941.    CALL med_initialize_nest_nmm( grid &   
    2942. 

  2942. !
    2943. 

  2943. # include <actual_new_args.inc>
    2944. 

  2944. !
    2945. 

  2945.                        )
    2946. 

  2946. 

  2947. END SUBROUTINE med_init_domain_constants_nmm
    2948. 

  2948. 

  2949. SUBROUTINE med_initialize_nest_nmm( grid &
    2950. 

  2950. !
    2951. 

  2951. # include <dummy_new_args.inc>
    2952. 

  2952. !
    2953. 

  2953.                            )
    2954. 

  2954. 

  2955.  USE module_domain
    2956. 

  2956.  USE module_configure
    2957. 

  2957.  USE module_timing
    2958. 

  2958.  IMPLICIT NONE
    2959. 

  2959. 

  2960. ! Local domain indices and counters.
    2961. 

  2961. 

  2962.  INTEGER :: ids, ide, jds, jde, kds, kde, &
    2963. 

  2963.             ims, ime, jms, jme, kms, kme, &
    2964. 

  2964.             its, ite, jts, jte, kts, kte, &
    2965. 

  2965.             i, j, k, nnxp, nnyp 
    2966. 

  2966. 

  2967.  TYPE(domain) , POINTER                     :: grid
    2968. 

  2968. 

  2969. ! Local data
    2970. 

  2970. 

  2971.  LOGICAL, EXTERNAL                   :: wrf_dm_on_monitor
    2972. 

  2972.  INTEGER                             :: KHH,KVH,JAM,JA,IHL, IHH, L
    2973. 

  2973.  INTEGER                             :: II,JJ,ISRCH,ISUM
    2974. 

  2974.  INTEGER, ALLOCATABLE, DIMENSION(:)  :: KHL2,KVL2,KHH2,KVH2,KHLA,KHHA,KVLA,KVHA
    2975. 

  2975.  INTEGER,PARAMETER                   :: KNUM=SELECTED_REAL_KIND(13)
    2976. 

  2976. !
    2977. 

  2977.  REAL(KIND=KNUM)                     :: WB,SB,DLM,DPH,TPH0,STPH0,CTPH0
    2978. 

  2978.  REAL(KIND=KNUM)                     :: STPH,CTPH,TDLM,TDPH,FP,TPH,TLM,TLM0
    2979. 

  2979.  REAL                                :: TPH0D,TLM0D,ANBI,TSPH,DTAD,DTCF,DT
    2980. 

  2980.  REAL                                :: ACDT,CDDAMP,DXP
    2981. 

  2981.  REAL                                :: WBD,SBD,WBI,SBI,EBI
    2982. 

  2982.  REAL                                :: DY_NMM0
    2983. 

  2983.  REAL                                :: RSNOW,SNOFAC
    2984. 

  2984.  REAL, ALLOCATABLE, DIMENSION(:)     :: DXJ,WPDARJ,CPGFUJ,CURVJ,   &
    2985. 

  2985.                                         FCPJ,FDIVJ,EMJ,EMTJ,FADJ,  &
    2986. 

  2986.                                         HDACJ,DDMPUJ,DDMPVJ
    2987. 

  2987. !
    2988. 

  2988.  REAL, PARAMETER:: SALP=2.60
    2989. 

  2989.  REAL, PARAMETER:: SNUP=0.040
    2990. 

  2990.  REAL, PARAMETER:: W_NMM=0.08
    2991. 

  2991. ! REAL, PARAMETER:: COAC=0.75
    2992. 

  2992.  REAL, PARAMETER:: CODAMP=6.4
    2993. 

  2993.  REAL, PARAMETER:: TWOM=.00014584
    2994. 

  2994.  REAL, PARAMETER:: CP=1004.6
    2995. 

  2995.  REAL, PARAMETER:: DFC=1.0    
    2996. 

  2996.  REAL, PARAMETER:: DDFC=1.0  
    2997. 

  2997.  REAL, PARAMETER:: ROI=916.6
    2998. 

  2998.  REAL, PARAMETER:: R=287.04
    2999. 

  2999.  REAL, PARAMETER:: CI=2060.0
    3000. 

  3000.  REAL, PARAMETER:: ROS=1500.
    3001. 

  3001.  REAL, PARAMETER:: CS=1339.2
    3002. 

  3002.  REAL, PARAMETER:: DS=0.050
    3003. 

  3003.  REAL, PARAMETER:: AKS=.0000005
    3004. 

  3004.  REAL, PARAMETER:: DZG=2.85
    3005. 

  3005.  REAL, PARAMETER:: DI=.1000
    3006. 

  3006.  REAL, PARAMETER:: AKI=0.000001075
    3007. 

  3007.  REAL, PARAMETER:: DZI=2.0
    3008. 

  3008.  REAL, PARAMETER:: THL=210.
    3009. 

  3009.  REAL, PARAMETER:: PLQ=70000.
    3010. 

  3010.  REAL, PARAMETER:: ERAD=6371200.
    3011. 

  3011.  REAL, PARAMETER:: DTR=0.01745329
    3012. 

  3012. 

  3013.  REAL :: COAC
    3014. 

  3014. 

  3015.  CHARACTER(LEN=255) :: message
    3016. 

  3016. 

  3017.    !  Definitions of dummy arguments to solve
    3018. 

  3018. #include <dummy_new_decl.inc>
    3019. 

  3019. 

  3020. !#define COPY_IN
    3021. 

  3021. !#include <scalar_derefs.inc>
    3022. 

  3022. #ifdef DM_PARALLEL
    3023. 

  3023. #      include <data_calls.inc>
    3024. 

  3024. #endif
    3025. 

  3025. 

  3026.    CALL get_ijk_from_grid (  grid ,                           &
    3027. 

  3027.                              ids, ide, jds, jde, kds, kde,    &
    3028. 

  3028.                              ims, ime, jms, jme, kms, kme,    &
    3029. 

  3029.                              its, ite, jts, jte, kts, kte     )
    3030. 

  3030. 

  3031. 

  3032. !=================================================================================
    3033. 

  3033. !
    3034. 

  3034. !
    3035. 

  3035. 

  3036.    call nl_get_coac(grid%id,coac)
    3037. 

  3037. 

  3038.     DT=grid%dt         !float(TIME_STEP)/parent_time_step_ratio
    3039. 

  3039.     NNXP=min(ITE,IDE-1)
    3040. 

  3040.     NNYP=min(JTE,JDE-1)
    3041. 

  3041.     JAM=6+2*((JDE-1)-10)         ! this should be the fix instead of JAM=6+2*(NNYP-10)
    3042. 

  3042. 

  3043.     WRITE(message,*)'TIME STEP ON DOMAIN',grid%id,'==',dt
    3044. 

  3044.     CALL wrf_message(trim(message))
    3045. 

  3045. 

  3046.     WRITE(message,*)'IDS,IDE ON DOMAIN',grid%id,'==',ids,ide
    3047. 

  3047.     CALL wrf_message(trim(message))
    3048. 

  3048. !
    3049. 

  3049.     ALLOCATE(KHL2(JTS:NNYP),KVL2(JTS:NNYP),KHH2(JTS:NNYP),KVH2(JTS:NNYP))
    3050. 

  3050.     ALLOCATE(DXJ(JTS:NNYP),WPDARJ(JTS:NNYP),CPGFUJ(JTS:NNYP),CURVJ(JTS:NNYP))
    3051. 

  3051.     ALLOCATE(FCPJ(JTS:NNYP),FDIVJ(JTS:NNYP),FADJ(JTS:NNYP))
    3052. 

  3052.     ALLOCATE(HDACJ(JTS:NNYP),DDMPUJ(JTS:NNYP),DDMPVJ(JTS:NNYP))
    3053. 

  3053.     ALLOCATE(KHLA(JAM),KHHA(JAM))
    3054. 

  3054.     ALLOCATE(KVLA(JAM),KVHA(JAM))
    3055. 

  3055. 

  3056. !   INITIALIZE SOME LAND/WATER SURFACE DATA ON THE BASIS OF INPUTS: SM, XICE, WEASD, 
    3057. 

  3057. !   INTERPOLATED FROM MOTHER (WRFSI) DOMAIN. THIS PART OF THE CODE HAS TO BE REVISITED
    3058. 

  3058. !   LATER ON
    3059. 

  3059. 

  3060. !   Since SM has been changed on parent domain to be 0 over sea ice it can not be used here
    3061. 

  3061. !   to find where sea ice is. That's why alogirthm here is slightly different than the
    3062. 

  3062. !   one used in module_initalize_real.f
    3063. 

  3063. 

  3064. #ifdef HWRF
    3065. 

  3065. !zhang's doing: added to AVOID THIS COMPUTATION IF THE NEST IS STARTED USING ANALYSIS FILE
    3066. 

  3066.    IF(.not. grid%analysis)THEN
    3067. 

  3067. #endif
    3068. 

  3068.     DO J = JTS, MIN(JTE,JDE-1)
    3069. 

  3069.      DO I = ITS, MIN(ITE,IDE-1)
    3070. 

  3070. 

  3071.       IF (grid%sm(I,J).GT.0.9) THEN                              ! OVER WATER SURFACE
    3072. 

  3072.          grid%epsr(I,J)= 0.97
    3073. 

  3073.          grid%embck(I,J)= 0.97
    3074. 

  3074.          grid%gffc(I,J)= 0.
    3075. 

  3075.          grid%albedo(I,J)=.06
    3076. 

  3076.          grid%albase(I,J)=.06
    3077. 

  3077.       ENDIF
    3078. 

  3078. 

  3079.       IF (grid%sice(I,J).GT.0.9) THEN                            ! OVER SEA-ICE
    3080. 

  3080.          grid%sm(I,J)=0.
    3081. 

  3081.          grid%si(I,J)=0.
    3082. 

  3082.          grid%gffc(I,J)=0.
    3083. 

  3083.          grid%albedo(I,J)=.60
    3084. 

  3084.          grid%albase(I,J)=.60
    3085. 

  3085.       ENDIF
    3086. 

  3086. 

  3087.       IF (grid%sm(I,J).LT.0.5.AND.grid%sice(I,J).LT.0.5) THEN         ! OVER LAND SURFACE
    3088. 

  3088.            grid%si(I,J)=5.0*grid%weasd(I,J)/1000. ! SNOW WATER EQ (mm) OBTAINED FROM PARENT (grid%si) IS INTERPOLATED
    3089. 

  3089.            grid%epsr(I,J)=1.0                ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN
    3090. 

  3090.            grid%embck(I,J)=1.0               ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN
    3091. 

  3091.            grid%gffc(I,J)=0.0                ! just leave zero as irrelevant
    3092. 

  3092.            grid%sno(I,J)=grid%si(I,J)*.20         ! LAND-SNOW COVER
    3093. 

  3093.       ENDIF
    3094. 

  3094. 

  3095.      ENDDO
    3096. 

  3096.     ENDDO
    3097. 

  3097. 

  3098. #if 0
    3099. 

  3099.     DO J = JTS, MIN(JTE,JDE-1)
    3100. 

  3100.      DO I = ITS, MIN(ITE,IDE-1)
    3101. 

  3101.       IF(grid%sm(I,J).GT.0.9) THEN           ! OVER WATER SURFACE
    3102. 

  3102. !
    3103. 

  3103.            IF (XICE(I,J) .gt. 0)THEN    ! XICE: SI INPUT ON PARENT, INTERPOLATED ONTO NEST
    3104. 

  3104.              grid%si(I,J)=1.0                ! INITIALIZE SI BASED ON XICE FROM INTERPOLATED INPUT
    3105. 

  3105.            ENDIF
    3106. 

  3106. !
    3107. 

  3107.            grid%epsr(I,J)= 0.97              ! VALID OVER SEA SURFACE
    3108. 

  3108.            grid%embck(I,J)= 0.97              ! VALID OVER SEA SURFACE
    3109. 

  3109.            grid%gffc(I,J)= 0.
    3110. 

  3110.            grid%albedo(I,J)=.06
    3111. 

  3111.            grid%albase(I,J)=.06
    3112. 

  3112. !
    3113. 

  3113.               IF(grid%si (I,J) .GT. 0.)THEN  ! VALID OVER SEA-ICE 
    3114. 

  3114.                  grid%sm(I,J)=0.
    3115. 

  3115.                  grid%si(I,J)=0.             ! 
    3116. 

  3116.                  grid%sice(I,J)=1.
    3117. 

  3117.                  grid%gffc(I,J)=0.           ! just leave zero as irrelevant
    3118. 

  3118.                  grid%albedo(I,J)=.60        ! DEFINE grid%albedo 
    3119. 

  3119.                  grid%albase(I,J)=.60
    3120. 

  3120.               ENDIF
    3121. 

  3121. !
    3122. 

  3122.       ELSE                              ! OVER LAND SURFACE
    3123. 

  3123. !
    3124. 

  3124.            grid%si(I,J)=5.0*grid%weasd(I,J)/1000. ! SNOW WATER EQ (mm) OBTAINED FROM PARENT (grid%si) IS INTERPOLATED 
    3125. 

  3125.            grid%epsr(I,J)=1.0                ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN
    3126. 

  3126.            grid%embck(I,J)=1.0                ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN
    3127. 

  3127.            grid%gffc(I,J)=0.0                ! just leave zero as irrelevant
    3128. 

  3128.            grid%sice(I,J)=0.                 ! SEA ICE
    3129. 

  3129.            grid%sno(I,J)=grid%si(I,J)*.20         ! LAND-SNOW COVER 
    3130. 

  3130. !
    3131. 

  3131.       ENDIF
    3132. 

  3132. !
    3133. 

  3133.      ENDDO
    3134. 

  3134.     ENDDO
    3135. 

  3135. #endif
    3136. 

  3136. 

  3137. !   This may just be a fix and may need some Registry related changes, later on
    3138. 

  3138. 

  3139.     DO J = JTS, MIN(JTE,JDE-1)
    3140. 

  3140.      DO I = ITS, MIN(ITE,IDE-1)
    3141. 

  3141.          grid%vegfra(I,J)=grid%vegfrc(I,J)
    3142. 

  3142.      ENDDO
    3143. 

  3143.     ENDDO
    3144. 

  3144. 

  3145. !   DETERMINE ALBEDO OVER LAND ON THE BASIS OF INPUTS: SM, ALBASE, MXSNAL & VEGFRA
    3146. 

  3146. !   INTERPOLATED FROM MOTHER (WRFSI) DOMAIN
    3147. 

  3147. 

  3148.  
    3149. 

  3149.     DO J = JTS, MIN(JTE,JDE-1) 
    3150. 

  3150.      DO I = ITS, MIN(ITE,IDE-1)
    3151. 

  3151. 

  3152.           IF(grid%sm(I,J).LT.0.9.AND.grid%sice(I,J).LT.0.9) THEN
    3153. 

  3153. !
    3154. 

  3154.             IF ( (grid%sno(I,J) .EQ. 0.0) .OR. &            ! SNOWFREE ALBEDO
    3155. 

  3155.                            (grid%albase(I,J) .GE. grid%mxsnal(I,J) ) ) THEN
    3156. 

  3156.               grid%albedo(I,J) = grid%albase(I,J)
    3157. 

  3157.             ELSE
    3158. 

  3158.               IF (grid%sno(I,J) .LT. SNUP) THEN             ! MODIFY ALBEDO IF SNOWCOVER:
    3159. 

  3159.                   RSNOW = grid%sno(I,J)/SNUP                ! BELOW SNOWDEPTH THRESHOLD
    3160. 

  3160.                   SNOFAC = 1. - ( EXP(-SALP*RSNOW) - RSNOW*EXP(-SALP))
    3161. 

  3161.               ELSE
    3162. 

  3162.                   SNOFAC = 1.0                         ! ABOVE SNOWDEPTH THRESHOLD
    3163. 

  3163.               ENDIF
    3164. 

  3164.               grid%albedo(I,J) = grid%albase(I,J) &
    3165. 

  3165.                           + (1.0-grid%vegfra(I,J))*SNOFAC*(grid%mxsnal(I,J)-grid%albase(I,J))
    3166. 

  3166.             ENDIF
    3167. 

  3167. !
    3168. 

  3168.           END IF
    3169. 

  3169. 

  3170.           grid%si(I,J)=5.0*grid%weasd(I,J)
    3171. 

  3171.           grid%sno(I,J)=grid%weasd(I,J)
    3172. 

  3172. ! this block probably superfluous.  Meant to guarantee land/sea agreement
    3173. 

  3173. 

  3174.         IF (grid%sm(I,J) .gt. 0.5)THEN 
    3175. 

  3175.            grid%landmask(I,J)=0.0
    3176. 

  3176.         ELSE 
    3177. 

  3177.            grid%landmask(I,J)=1.0
    3178. 

  3178.         ENDIF 
    3179. 

  3179. 

  3180.         IF (grid%sice(I,J) .eq. 1.0) then !!!! change vegtyp and sltyp to fit seaice (desireable??)
    3181. 

  3181.          grid%isltyp(I,J)=16
    3182. 

  3182.          grid%ivgtyp(I,J)=24
    3183. 

  3183.         ENDIF 
    3184. 

  3184. 

  3185.      ENDDO
    3186. 

  3186.     ENDDO
    3187. 

  3187. 

  3188. !  Check land water interface
    3189. 

  3189. 

  3190. !     The write(20,*) statements below were very slow on Jet when using
    3191. 

  3191. !     the intel compiler (added hours to the runtime).  The fix
    3192. 

  3192. !     suggested by Chris Harrop was to send messages to wrf_message
    3193. 

  3193. !     instead:
    3194. 

  3194. 

  3195.     DO J = JTS, MIN(JTE,JDE-1)
    3196. 

  3196.      DO I = ITS,MIN(ITE,IDE-1)
    3197. 

  3197.       IF(grid%sm(I,J).GT.0.9 .AND. grid%vegfra(I,J) .NE. 0) THEN
    3198. 

  3198. #if defined(USE_SLOW_INTERFACE_CHECK)
    3199. 

  3199.         WRITE(20,*)'PROBLEM AT THE LAND-WATER INTERFACE (VEGFRA):', &
    3200. 

  3200.              I,J,grid%sm(I-1,J),grid%vegfra(I-1,j),grid%sm(I,J),grid%vegfra(I,J)
    3201. 

  3201. #else
    3202. 

  3202.         WRITE(message,*)'PROBLEM AT THE LAND-WATER INTERFACE (VEGFRA):', &
    3203. 

  3203.              I,J,grid%sm(I-1,J),grid%vegfra(I-1,j),grid%sm(I,J),grid%vegfra(I,J)
    3204. 

  3204.         CALL wrf_message(trim(message))
    3205. 

  3205. #endif
    3206. 

  3206.       ENDIF
    3207. 

  3207. !
    3208. 

  3208. #if defined(HWRF)
    3209. 

  3209.       ! HWRF should not perform the check below because the nmm_tsk is
    3210. 

  3210.       ! update with the correct skin temperature every timestep (on both
    3211. 

  3211.       ! land and sea points).
    3212. 

  3212. #else
    3213. 

  3213.       IF(grid%sm(I,J).GT.0.9 .AND. grid%nmm_tsk(I,J) .NE. 0) THEN
    3214. 

  3214. #if defined(USE_SLOW_INTERFACE_CHECK)
    3215. 

  3215.         WRITE(20,*)'PROBLEM AT THE LAND-WATER INTERFACE (NMM_TSK):', &
    3216. 

  3216.              I,J,grid%sm(I-1,J),grid%nmm_tsk(I-1,J),grid%sm(I,J),grid%nmm_tsk(I,J)
    3217. 

  3217. #else
    3218. 

  3218.         WRITE(message,*)'PROBLEM AT THE LAND-WATER INTERFACE (NMM_TSK):', &
    3219. 

  3219.              I,J,grid%sm(I-1,J),grid%nmm_tsk(I-1,J),grid%sm(I,J),grid%nmm_tsk(I,J)
    3220. 

  3220.         CALL wrf_message(trim(message))
    3221. 

  3221. #endif
    3222. 

  3222.       ENDIF
    3223. 

  3223. #endif
    3224. 

  3224.      ENDDO
    3225. 

  3225.     ENDDO
    3226. 

  3226. 

  3227. 

  3228. !   hardwire root depth for time being
    3229. 

  3229. 

  3230.         grid%rtdpth=0.
    3231. 

  3231.         grid%rtdpth(1)=0.1
    3232. 

  3232.         grid%rtdpth(2)=0.3
    3233. 

  3233.         grid%rtdpth(3)=0.6
    3234. 

  3234. 

  3235. !   hardwire soil depth for time being
    3236. 

  3236. 

  3237.         grid%sldpth=0.
    3238. 

  3238.         grid%sldpth(1)=0.1
    3239. 

  3239.         grid%sldpth(2)=0.3
    3240. 

  3240.         grid%sldpth(3)=0.6
    3241. 

  3241.         grid%sldpth(4)=1.0
    3242. 

  3242. 

  3243. #ifdef HWRF
    3244. 

  3244. !zhang's doing: added to AVOID THIS COMPUTATION IF THE NEST IS STARTED USING ANALYSIS FILE
    3245. 

  3245.    ENDIF ! <------ for analysis set to false
    3246. 

  3246. #endif 
    3247. 

  3247. !-----------  END OF LAND SURFACE INITIALIZATION -------------------------------------
    3248. 

  3248. !
    3249. 

  3249.     DO J = JTS, MIN(JTE,JDE-1)
    3250. 

  3250.      DO I = ITS, MIN(ITE,IDE-1)
    3251. 

  3251.        grid%res(I,J)=1.
    3252. 

  3252.      ENDDO
    3253. 

  3253.     ENDDO
    3254. 

  3254. 

  3255. !   INITIALIZE 2D BOUNDARY MASKS
    3256. 

  3256. 

  3257. !! grid%hbm2:
    3258. 

  3258.  
    3259. 

  3259.     grid%hbm2=0.
    3260. 

  3260.     DO J = JTS, MIN(JTE,JDE-1)
    3261. 

  3261.       DO I = ITS, MIN(ITE,IDE-1)
    3262. 

  3262.        IF((J .GE. 3 .and. J .LE. (JDE-1)-2) .AND.   &
    3263. 

  3263.           (I .GE. 2 .and. I .LE. (IDE-1)-2+MOD(J,2))) THEN
    3264. 

  3264.           grid%hbm2(I,J)=1.
    3265. 

  3265.         ENDIF
    3266. 

  3266.       ENDDO
    3267. 

  3267.     ENDDO   
    3268. 

  3268. 

  3269. !! grid%hbm3:
    3270. 

  3270. 

  3271.     grid%hbm3=0.
    3272. 

  3272.     DO J=JTS,MIN(JTE,JDE-1)
    3273. 

  3273.      grid%ihwg(J)=mod(J+1,2)-1
    3274. 

  3274.       IF (J .ge. 4 .and. J .le. (JDE-1)-3) THEN
    3275. 

  3275.         IHL=(IDS+1)-grid%ihwg(J) 
    3276. 

  3276.         IHH=(IDE-1)-2
    3277. 

  3277.         DO I=ITS,MIN(ITE,IDE-1)
    3278. 

  3278.            IF (I .ge. IHL  .and. I .le. IHH) grid%hbm3(I,J)=1.
    3279. 

  3279.         ENDDO 
    3280. 

  3280.       ENDIF
    3281. 

  3281.     ENDDO 
    3282. 

  3282.    
    3283. 

  3283. !! grid%vbm2
    3284. 

  3284. 

  3285.     grid%vbm2=0.
    3286. 

  3286.     DO J=JTS,MIN(JTE,JDE-1)
    3287. 

  3287.      DO I=ITS,MIN(ITE,IDE-1)
    3288. 

  3288.        IF((J .ge. 3 .and. J .le. (JDE-1)-2)  .AND.  &
    3289. 

  3289.           (I .ge. 2 .and. I .le. (IDE-1)-1-MOD(J,2))) THEN
    3290. 

  3290.            grid%vbm2(I,J)=1.
    3291. 

  3291.        ENDIF
    3292. 

  3292.      ENDDO
    3293. 

  3293.     ENDDO
    3294. 

  3294. 

  3295. !! grid%vbm3
    3296. 

  3296. 

  3297.     grid%vbm3=0.
    3298. 

  3298.     DO J=JTS,MIN(JTE,JDE-1)
    3299. 

  3299.       DO I=ITS,MIN(ITE,IDE-1)
    3300. 

  3300.         IF((J .ge. 4 .and. J .le. (JDE-1)-3)  .AND.  &
    3301. 

  3301.            (I .ge. 3-MOD(J,2) .and. I .le. (IDE-1)-2)) THEN
    3302. 

  3302.            grid%vbm3(I,J)=1.
    3303. 

  3303.         ENDIF
    3304. 

  3304.       ENDDO
    3305. 

  3305.     ENDDO
    3306. 

  3306. 

  3307.     TPH0D  = grid%CEN_LAT
    3308. 

  3308.     TLM0D  = grid%CEN_LON
    3309. 

  3309.     TPH0   = TPH0D*DTR
    3310. 

  3310.     WBD    = grid%WBD0   ! gopal's doing: may use Registry WBD0 now
    3311. 

  3311.     WB     = WBD*DTR
    3312. 

  3312.     SBD    = grid%SBD0   ! gopal's doing: may use Registry SBD0 now
    3313. 

  3313.     SB     = SBD*DTR
    3314. 

  3314.     DLM    = grid%dlmd*DTR  ! input now from med_nest_egrid_configure
    3315. 

  3315.     DPH    = grid%dphd*DTR  ! input now from med_nest_egrid_configure
    3316. 

  3316.     TDLM   = DLM+DLM
    3317. 

  3317.     TDPH   = DPH+DPH
    3318. 

  3318.     WBI    = WB+TDLM
    3319. 

  3319.     SBI    = SB+TDPH
    3320. 

  3320.     EBI    = WB+((ide-1)-2)*TDLM  ! gopal's doing: check this for nested domain
    3321. 

  3321.     ANBI   = SB+((jde-1)-3)*DPH   ! gopal's doing: check this for nested domain
    3322. 

  3322.     STPH0  = SIN(TPH0)
    3323. 

  3323.     CTPH0  = COS(TPH0)
    3324. 

  3324.     TSPH   = 3600./grid%DT
    3325. 

  3325.     DTAD   = 1.0
    3326. 

  3326.     DTCF   = 4.0    
    3327. 

  3327.     DY_NMM0= grid%dy_nmm ! ERAD*DPH; input now from med_nest_egrid_configure
    3328. 

  3328. 

  3329. !   CORIOLIS PARAMETER  (There appears to be some roundoff in computing TLM & STPH and other terms,
    3330. 

  3330. !   in the nested domain. The problem needs to be revisited
    3331. 

  3331. 

  3332.     DO J=JTS,MIN(JTE,JDE-1)
    3333. 

  3333.       TLM0=WB-TDLM+MOD(J,2)*DLM           ! remember this is a wind point
    3334. 

  3334.       TPH =SB+float(J-1)*DPH
    3335. 

  3335.       STPH=SIN(TPH)
    3336. 

  3336.       CTPH=COS(TPH)
    3337. 

  3337.       DO I=ITS,MIN(ITE,IDE-1)
    3338. 

  3338.          TLM=TLM0 + I*TDLM
    3339. 

  3339.          FP=TWOM*(CTPH0*STPH+STPH0*CTPH*COS(TLM))
    3340. 

  3340.          grid%f(I,J)=0.5*grid%DT*FP
    3341. 

  3341.       ENDDO
    3342. 

  3342.     ENDDO
    3343. 

  3343. 

  3344. 

  3345.     DO J=JTS,MIN(JTE,JDE-1)
    3346. 

  3346.       KHL2(J)=(IDE-1)*(J-1)-(J-1)/2+2
    3347. 

  3347.       KVL2(J)=(IDE-1)*(J-1)-J/2+2
    3348. 

  3348.       KHH2(J)=(IDE-1)*J-J/2-1
    3349. 

  3349.       KVH2(J)=(IDE-1)*J-(J+1)/2-1
    3350. 

  3350.     ENDDO
    3351. 

  3351. 

  3352. 

  3353.     TPH=SB-DPH
    3354. 

  3354.     DO J=JTS,MIN(JTE,JDE-1)
    3355. 

  3355.       TPH=SB+float(J-1)*DPH
    3356. 

  3356.       DXP=ERAD*DLM*COS(TPH)
    3357. 

  3357.       DXJ(J)=DXP
    3358. 

  3358.       WPDARJ(J)=-W_NMM*((ERAD*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+DY_NMM0**2)/  & 
    3359. 

  3359.                 (grid%DT*32.*DXP*DY_NMM0)
    3360. 

  3360.       CPGFUJ(J)=-grid%DT/(48.*DXP)
    3361. 

  3361.       CURVJ(J)=.5*grid%DT*TAN(TPH)/ERAD
    3362. 

  3362.       FCPJ(J)=grid%DT/(CP*192.*DXP*DY_NMM0)
    3363. 

  3363.       FDIVJ(J)=1./(12.*DXP*DY_NMM0)
    3364. 

  3364.       FADJ(J)=-grid%DT/(48.*DXP*DY_NMM0)*DTAD
    3365. 

  3365.       ACDT=grid%DT*SQRT((ERAD*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+DY_NMM0**2)
    3366. 

  3366.       CDDAMP=CODAMP*ACDT
    3367. 

  3367.       HDACJ(J)=COAC*ACDT/(4.*DXP*DY_NMM0)
    3368. 

  3368.       DDMPUJ(J)=CDDAMP/DXP
    3369. 

  3369.       DDMPVJ(J)=CDDAMP/DY_NMM0
    3370. 

  3370.     ENDDO
    3371. 

  3371. 

  3372. ! --------------DERIVED VERTICAL GRID CONSTANTS--------------------------
    3373. 

  3373. 

  3374.      WRITE(message,*)'NEW CHANGE',grid%f4d,grid%ef4t,grid%f4q
    3375. 

  3375.      CALL wrf_message(trim(message))
    3376. 

  3376. 

  3377.       DO L=KDS,KDE-1
    3378. 

  3378.         grid%rdeta(L)=1./grid%deta(L)
    3379. 

  3379.         grid%f4q2(L)=-.25*grid%DT*DTAD/grid%deta(L)
    3380. 

  3380.       ENDDO
    3381. 

  3381. 

  3382.        DO J=JTS,MIN(JTE,JDE-1)
    3383. 

  3383.         DO I=ITS,MIN(ITE,IDE-1)
    3384. 

  3384.           grid%dx_nmm(I,J)=DXJ(J)
    3385. 

  3385.           grid%wpdar(I,J)=WPDARJ(J)*grid%hbm2(I,J)
    3386. 

  3386.           grid%cpgfu(I,J)=CPGFUJ(J)*grid%vbm2(I,J)
    3387. 

  3387.           grid%curv(I,J)=CURVJ(J)*grid%vbm2(I,J)
    3388. 

  3388.           grid%fcp(I,J)=FCPJ(J)*grid%hbm2(I,J)
    3389. 

  3389.           grid%fdiv(I,J)=FDIVJ(J)*grid%hbm2(I,J)
    3390. 

  3390.           grid%fad(I,J)=FADJ(J)
    3391. 

  3391.           grid%hdacv(I,J)=HDACJ(J)*grid%vbm2(I,J)
    3392. 

  3392.           grid%hdac(I,J)=HDACJ(J)*1.25*grid%hbm2(I,J)
    3393. 

  3393.         ENDDO
    3394. 

  3394.        ENDDO
    3395. 

  3395. 

  3396.        DO J=JTS, MIN(JTE,JDE-1)
    3397. 

  3397.         IF (J.LE.5.OR.J.GE.(JDE-1)-4) THEN
    3398. 

  3398.           KHH=(IDE-1)-2+MOD(J,2) ! KHH is global...loop over I that have
    3399. 

  3399.           DO I=ITS,MIN(ITE,IDE-1)
    3400. 

  3400.              IF (I .ge. 2 .and. I .le. KHH) THEN
    3401. 

  3401.                grid%hdac(I,J)=grid%hdac(I,J)* DFC
    3402. 

  3402.              ENDIF
    3403. 

  3403.           ENDDO
    3404. 

  3404.         ELSE
    3405. 

  3405.           KHH=2+MOD(J,2)
    3406. 

  3406.           DO I=ITS,MIN(ITE,IDE-1)
    3407. 

  3407.              IF (I .ge. 2 .and. I .le. KHH) THEN
    3408. 

  3408.                grid%hdac(I,J)=grid%hdac(I,J)* DFC
    3409. 

  3409.              ENDIF
    3410. 

  3410.           ENDDO
    3411. 

  3411.           KHH=(IDE-1)-2+MOD(J,2)
    3412. 

  3412. 

  3413.           DO I=ITS,MIN(ITE,IDE-1)
    3414. 

  3414.              IF (I .ge. (IDE-1)-2 .and. I .le. KHH) THEN
    3415. 

  3415.                grid%hdac(I,J)=grid%hdac(I,J)* DFC
    3416. 

  3416.              ENDIF
    3417. 

  3417.           ENDDO
    3418. 

  3418.         ENDIF
    3419. 

  3419.       ENDDO
    3420. 

  3420. 

  3421.       DO J=JTS,min(JTE,JDE-1)
    3422. 

  3422.       DO I=ITS,min(ITE,IDE-1)
    3423. 

  3423.         grid%ddmpu(I,J)=DDMPUJ(J)*grid%vbm2(I,J)
    3424. 

  3424.         grid%ddmpv(I,J)=DDMPVJ(J)*grid%vbm2(I,J)
    3425. 

  3425.         grid%hdacv(I,J)=grid%hdacv(I,J)*grid%vbm2(I,J)
    3426. 

  3426.       ENDDO
    3427. 

  3427.       ENDDO
    3428. 

  3428. 

  3429. ! --------------INCREASING DIFFUSION ALONG THE BOUNDARIES----------------
    3430. 

  3430. 

  3431.         DO J=JTS,MIN(JTE,JDE-1)
    3432. 

  3432.         IF (J.LE.5.OR.J.GE.JDE-1-4) THEN
    3433. 

  3433.           KVH=(IDE-1)-1-MOD(J,2)
    3434. 

  3434.           DO I=ITS,MIN(ITE,IDE-1)
    3435. 

  3435.             IF (I .ge. 2 .and.  I .le. KVH) THEN
    3436. 

  3436.              grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC
    3437. 

  3437.              grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC
    3438. 

  3438.              grid%hdacv(I,J)=grid%hdacv(I,J)*DFC
    3439. 

  3439.             ENDIF
    3440. 

  3440.           ENDDO
    3441. 

  3441.         ELSE
    3442. 

  3442.           KVH=3-MOD(J,2)
    3443. 

  3443.           DO I=ITS,MIN(ITE,IDE-1)
    3444. 

  3444.            IF (I .ge. 2 .and.  I .le. KVH) THEN
    3445. 

  3445.             grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC
    3446. 

  3446.             grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC
    3447. 

  3447.             grid%hdacv(I,J)=grid%hdacv(I,J)*DFC
    3448. 

  3448.            ENDIF
    3449. 

  3449.           ENDDO
    3450. 

  3450.           KVH=(IDE-1)-1-MOD(J,2)
    3451. 

  3451.           DO I=ITS,MIN(ITE,IDE-1)
    3452. 

  3452.            IF (I .ge. IDE-1-2 .and. I .le. KVH) THEN
    3453. 

  3453.             grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC
    3454. 

  3454.             grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC
    3455. 

  3455.             grid%hdacv(I,J)=grid%hdacv(I,J)*DFC
    3456. 

  3456.            ENDIF
    3457. 

  3457.           ENDDO
    3458. 

  3458.         ENDIF
    3459. 

  3459.       ENDDO
    3460. 

  3460. 

  3461. ! This one was left over for nested domain
    3462. 

  3462.  
    3463. 

  3463.      DO J = JTS, MIN(JTE,JDE-1)
    3464. 

  3464.        DO I = ITS, MIN(ITE,IDE-1)
    3465. 

  3465.           grid%GLAT(I,J)=grid%HLAT(I,J)*DTR
    3466. 

  3466.           grid%GLON(I,J)=grid%HLON(I,J)*DTR
    3467. 

  3467.        ENDDO
    3468. 

  3468.      ENDDO
    3469. 

  3469. 

  3470. !!   compute EMT, EM on global domain, and only on task 0.
    3471. 

  3471. 

  3472. !    IF (wrf_dm_on_monitor()) THEN   !!!! NECESSARY TO LIMIT THIS TO TASK ZERO?
    3473. 

  3473.       
    3474. 

  3474.      ALLOCATE(EMJ(JDS:JDE-1),EMTJ(JDS:JDE-1))
    3475. 

  3475.      DO J=JDS,JDE-1
    3476. 

  3476.        TPH=SB+float(J-1)*DPH
    3477. 

  3477.        DXP=ERAD*DLM*COS(TPH)
    3478. 

  3478.        EMJ(J)= grid%DT/( 4.*DXP)*DTAD
    3479. 

  3479.        EMTJ(J)=grid%DT/(16.*DXP)*DTAD
    3480. 

  3480.      ENDDO
    3481. 

  3481. 

  3482.           JA=0
    3483. 

  3483.           DO 161 J=3,5
    3484. 

  3484.           JA=JA+1
    3485. 

  3485.           KHLA(JA)=2
    3486. 

  3486.           KHHA(JA)=(IDE-1)-1-MOD(J+1,2)
    3487. 

  3487.  161      grid%emt(JA)=EMTJ(J)
    3488. 

  3488.           DO 162 J=(JDE-1)-4,(JDE-1)-2
    3489. 

  3489.           JA=JA+1
    3490. 

  3490.           KHLA(JA)=2
    3491. 

  3491.           KHHA(JA)=(IDE-1)-1-MOD(J+1,2)
    3492. 

  3492.  162      grid%emt(JA)=EMTJ(J)
    3493. 

  3493.           DO 163 J=6,(JDE-1)-5
    3494. 

  3494.           JA=JA+1
    3495. 

  3495.           KHLA(JA)=2
    3496. 

  3496.           KHHA(JA)=2+MOD(J,2)
    3497. 

  3497.  163      grid%emt(JA)=EMTJ(J)
    3498. 

  3498.           DO 164 J=6,(JDE-1)-5
    3499. 

  3499.           JA=JA+1
    3500. 

  3500.           KHLA(JA)=(IDE-1)-2
    3501. 

  3501.           KHHA(JA)=(IDE-1)-1-MOD(J+1,2)
    3502. 

  3502.  164      grid%emt(JA)=EMTJ(J)
    3503. 

  3503. 

  3504. ! --------------SPREADING OF UPSTREAM VELOCITY-POINT ADVECTION FACTOR----
    3505. 

  3505. 

  3506.           JA=0
    3507. 

  3507.           DO 171 J=3,5
    3508. 

  3508.           JA=JA+1
    3509. 

  3509.           KVLA(JA)=2
    3510. 

  3510.           KVHA(JA)=(IDE-1)-1-MOD(J,2)
    3511. 

  3511.  171      grid%em(JA)=EMJ(J)
    3512. 

  3512.           DO 172 J=(JDE-1)-4,(JDE-2)-2
    3513. 

  3513.           JA=JA+1
    3514. 

  3514.           KVLA(JA)=2
    3515. 

  3515.           KVHA(JA)=(IDE-1)-1-MOD(J,2)
    3516. 

  3516.  172      grid%em(JA)=EMJ(J)
    3517. 

  3517.           DO 173 J=6,(JDE-1)-5
    3518. 

  3518.           JA=JA+1
    3519. 

  3519.           KVLA(JA)=2
    3520. 

  3520.           KVHA(JA)=2+MOD(J+1,2)
    3521. 

  3521.  173      grid%em(JA)=EMJ(J)
    3522. 

  3522.           DO 174 J=6,(JDE-1)-5
    3523. 

  3523.           JA=JA+1
    3524. 

  3524.           KVLA(JA)=(IDE-1)-2
    3525. 

  3525.           KVHA(JA)=(IDE-1)-1-MOD(J,2)
    3526. 

  3526.  174      grid%em(JA)=EMJ(J)
    3527. 

  3527. 

  3528. !        ENDIF ! wrf_dm_on_monitor
    3529. 

  3529. 

  3530. !! must be a better place to put this, but will eliminate "phantom"
    3531. 

  3531. !! wind points here (no wind point on eastern boundary of odd numbered rows)
    3532. 

  3532. !!
    3533. 

  3533.                                                                 !   phantom
    3534. 

  3534.         IF (ABS(IDE-1-ITE) .eq. 1 ) THEN                        !      | 
    3535. 

  3535.          CALL wrf_message('zero phantom winds')                 !  H  [x]    H    V
    3536. 

  3536.          DO K=KDS,KDE-1                                         !  
    3537. 

  3537.           DO J=JDS,JDE-1,2                                      !  V  [H]    V    H
    3538. 

  3538.            IF (J .ge. JTS .and. J .le. JTE) THEN                !
    3539. 

  3539.              grid%u(IDE-1,J,K)=0.                                    !  H  [x]    H    V
    3540. 

  3540.              grid%v(IDE-1,J,K)=0.                                    !  ------    ------  
    3541. 

  3541.            ENDIF                                                !   ide-1      ide
    3542. 

  3542.           ENDDO                                                 !   NMM/si     WRF
    3543. 

  3543.          ENDDO                                                  !   domain    domain
    3544. 

  3544.         ENDIF                                                   !             (dummy)   
    3545. 

  3545. 

  3546. 

  3547. ! just a test for gravity waves
    3548. 

  3548. 

  3549. !  PD=62000.
    3550. 

  3550. !   grid%u=0.0
    3551. 

  3551. !   grid%v=0.0
    3552. 

  3552. !   T=300.
    3553. 

  3553. !   Q=0.0
    3554. 

  3554. !   Q2=0.0
    3555. 

  3555. !   CWM=0.0
    3556. 

  3556. !   FIS=0.0
    3557. 

  3557. 

  3558. ! testx
    3559. 

  3559. !  DO J = JTS, MIN(JTE,JDE-1)
    3560. 

  3560. !   DO K = KTS,KTE
    3561. 

  3561. !    DO I = ITS, MIN(ITE,IDE-1)
    3562. 

  3562. !      grid%sm(I,J)=I
    3563. 

  3563. !       grid%u(I,K,J)=J
    3564. 

  3564. !    ENDDO
    3565. 

  3565. !   ENDDO
    3566. 

  3566. !  ENDDO
    3567. 

  3567. !
    3568. 

  3568. 

  3569. !   deallocs
    3570. 

  3570. 

  3571.     DEALLOCATE(KHL2,KVL2,KHH2,KVH2)
    3572. 

  3572.     DEALLOCATE(DXJ,WPDARJ,CPGFUJ,CURVJ)
    3573. 

  3573.     DEALLOCATE(FCPJ,FDIVJ,FADJ)
    3574. 

  3574.     DEALLOCATE(HDACJ,DDMPUJ,DDMPVJ)
    3575. 

  3575.     DEALLOCATE(KHLA,KHHA)
    3576. 

  3576.     DEALLOCATE(KVLA,KVHA)
    3577. 

  3577. 

  3578. 

  3579. END SUBROUTINE med_initialize_nest_nmm
    3580. 

  3580. !======================================================================
    3581. 

  3581. 

  3582. !--------------------------------------------------------------------------------------
    3583. 

  3583. #if 0
    3584. 

  3584. SUBROUTINE initial_nest_pivot ( parent , nest, iloc, jloc )
    3585. 

  3585. 

  3586. !==========================================================================================
    3587. 

  3587. !
    3588. 

  3588. ! This program produces i_start and j_start for the nested domain depending on the
    3589. 

  3589. ! central lat-lon of the storm.
    3590. 

  3590. !
    3591. 

  3591. !==========================================================================================
    3592. 

  3592. 

  3593.  USE module_domain
    3594. 

  3594.  USE module_configure
    3595. 

  3595.  USE module_timing
    3596. 

  3596.  USE module_dm 
    3597. 

  3597. 

  3598.  IMPLICIT NONE
    3599. 

  3599.  TYPE(domain) , POINTER              :: parent , nest
    3600. 

  3600.  INTEGER, INTENT(OUT)                :: ILOC,JLOC
    3601. 

  3601.  INTEGER                             :: IMS,IME,JMS,JME,KMS,KME
    3602. 

  3602.  INTEGER                             :: IDS,IDE,JDS,JDE,KDS,KDE
    3603. 

  3603.  INTEGER                             :: IMS,IME,JMS,JME,KMS,KME
    3604. 

  3604.  INTEGER                             :: ITS,ITE,JTS,JTE,KTS,KTE
    3605. 

  3605.  INTEGER                             :: NIDE,NJDE              ! nest dimension
    3606. 

  3606.  INTEGER                             :: I,J,ITER,IDUM,JDUM
    3607. 

  3607.  REAL                                :: ALAT,ALON,DIFF1,DIFF2,ERR
    3608. 

  3608.  REAL                                :: parent_CLAT,parent_CLON,parent_SLAT,parent_SLON
    3609. 

  3609.  REAL                                :: parent_WBD,parent_SBD,parent_DLMD,parent_DPHD 
    3610. 

  3610. !========================================================================================
    3611. 

  3611. 

  3612. !   First obtain central latitude and longitude for the parent domain
    3613. 

  3613. 

  3614.     CALL nl_get_cen_lat (parent%ID, parent_CLAT)
    3615. 

  3615.     CALL nl_get_cen_lon (parent%ID, parent_CLON)
    3616. 

  3616. !    CALL nl_get_storm_lat (parent%ID, parent_SLAT)
    3617. 

  3617. !    CALL nl_get_storm_lon (parent%ID, parent_SLON)
    3618. 

  3618. 

  3619. !   Parent grid configuration, including, western and southern boundary
    3620. 

  3620. 

  3621.     IDS = parent%sd31
    3622. 

  3622.     IDE = parent%ed31
    3623. 

  3623.     JDS = parent%sd32
    3624. 

  3624.     JDE = parent%ed32
    3625. 

  3625.     KDS = parent%sd33
    3626. 

  3626.     KDE = parent%ed33
    3627. 

  3627. 

  3628.     IMS = parent%sm31
    3629. 

  3629.     IME = parent%em31
    3630. 

  3630.     JMS = parent%sm32
    3631. 

  3631.     JME = parent%em32
    3632. 

  3632.     KMS = parent%sm33
    3633. 

  3633.     KME = parent%em33
    3634. 

  3634. 

  3635.     ITS  = parent%sp31
    3636. 

  3636.     ITE  = parent%ep31
    3637. 

  3637.     JTS  = parent%sp32
    3638. 

  3638.     JTE  = parent%ep32
    3639. 

  3639.     KTS  = parent%sp33
    3640. 

  3640.     KTE  = parent%ep33
    3641. 

  3641. 

  3642.     NIDE = nest%ed31
    3643. 

  3643.     NJDE = nest%ed32
    3644. 

  3644. 

  3645.     parent_DLMD = parent%dx          ! DLMD: dlamda in degrees
    3646. 

  3646.     parent_DPHD = parent%dy          ! DPHD: dphi in degrees
    3647. 

  3647.     parent_WBD  = -(IDE-2)*parent%dx ! WBD0: in deg;factor 2 takes care of dummy last column 
    3648. 

  3648.     parent_SBD  = -((JDE-1)/2)*parent%dy ! SBD0: in degrees; note that JDE-1 should be odd 
    3649. 

  3649.     ALAT  = parent_SLAT - 0.5*(NJDE-2)*parent_DPHD/nest%parent_grid_ratio
    3650. 

  3650.     ALON  = parent_SLON - 1.0*(NIDE-2)*parent_DLMD/nest%parent_grid_ratio
    3651. 

  3651. 

  3652.     CALL EARTH_LATLON ( parent%HLAT,parent%HLON,parent%VLAT,parent%VLON, & !output
    3653. 

  3653.                         parent_DLMD,parent_DPHD,parent_WBD,parent_SBD,                   & !inputs
    3654. 

  3654.                         parent_CLAT,parent_CLON,                                         &
    3655. 

  3655.                         IDS,IDE,JDS,JDE,KDS,KDE,                                         &
    3656. 

  3656.                         IMS,IME,JMS,JME,KMS,KME,                                         &
    3657. 

  3657.                         ITS,ITE,JTS,JTE,KTS,KTE                          )
    3658. 

  3658. 

  3659. !   start iteration
    3660. 

  3660. 

  3661.       ILOC=-99
    3662. 

  3662.       JLOC=-99
    3663. 

  3663.       ERR=0.1
    3664. 

  3664.       ITER=1
    3665. 

  3665. 100   CONTINUE
    3666. 

  3666. 

  3667.      DO J = JTS,min(JTE,JDE-1)
    3668. 

  3668.       DO I = ITS,min(ITE,IDE-1)
    3669. 

  3669.         DIFF1 = ABS(ALAT - parent%HLAT(I,J))
    3670. 

  3670.         DIFF2 = ABS(ALON - parent%HLON(I,J))
    3671. 

  3671.         IF(DIFF1 .LE. ERR .AND. DIFF2 .LE. ERR)THEN
    3672. 

  3672.          ILOC=I
    3673. 

  3673.          JLOC=J
    3674. 

  3674.         ENDIF
    3675. 

  3675.       ENDDO
    3676. 

  3676.      ENDDO
    3677. 

  3677. 

  3678.      CALL wrf_dm_maxval_integer ( ILOC, idum, jdum )
    3679. 

  3679.      CALL wrf_dm_maxval_integer ( JLOC, idum, jdum ) 
    3680. 

  3680. 

  3681.      IF(ILOC .EQ. -99 .AND. JLOC .EQ. -99)THEN
    3682. 

  3682.        ERR=ERR+0.1
    3683. 

  3683.        ITER=ITER+1
    3684. 

  3684.        IF(ITER .LE. 100)GO TO 100
    3685. 

  3685.      ENDIF
    3686. 

  3686. 

  3687.      IF(ILOC .NE. -99 .AND. JLOC .NE. -99)THEN
    3688. 

  3688.        WRITE(message,*)'NOTE: I_PARENT_START AND J_PARENT_START FOUND FOR THE NESTED DOMAIN CONFIGURATION AT ITER=',ITER
    3689. 

  3689.        CALL wrf_message(trim(message))
    3690. 

  3690.        WRITE(message,*)'istart=',ILOC
    3691. 

  3691.        CALL wrf_message(trim(message))
    3692. 

  3692.        WRITE(message,*)'jstart=',JLOC
    3693. 

  3693.        CALL wrf_message(trim(message))
    3694. 

  3694.      ELSE
    3695. 

  3695.        ILOC=IDE/3
    3696. 

  3696.        JLOC=JDE/3
    3697. 

  3697. !
    3698. 

  3698.        WRITE(message,*)'WARNING: COULD NOT LOCATE I_PARENT_START AND J_PARENT_START FROM INPUT STORM INFO'
    3699. 

  3699.        CALL wrf_message(trim(message))
    3700. 

  3700.        WRITE(message,*)'ISTART=',IDE/3
    3701. 

  3701.        CALL wrf_message(trim(message))
    3702. 

  3702.        WRITE(message,*)'JSTART=',JDE/3
    3703. 

  3703.        CALL wrf_message(trim(message))
    3704. 

  3704.      ENDIF
    3705. 

  3705. 

  3706.      RETURN
    3707. 

  3707. END SUBROUTINE initial_nest_pivot
    3708. 

  3708. 

  3709. !============================================================================================
    3710. 

  3710. #endif
    3711. 

  3711. 

  3712. LOGICAL FUNCTION cd_feedback_mask_orig( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, xstag, ystag )
    3713. 

  3713.    INTEGER, INTENT(IN) :: pig, ips_save, ipe_save , pjg, jps_save, jpe_save
    3714. 

  3714.    LOGICAL, INTENT(IN) :: xstag, ystag
    3715. 

  3715. 

  3716.    INTEGER ioff, joff
    3717. 

  3717. 

  3718.    ioff = 0 ; joff = 0
    3719. 

  3719.    IF ( xstag  ) ioff = 1
    3720. 

  3720.    IF ( ystag  ) joff = 1
    3721. 

  3721. 

  3722.    cd_feedback_mask_orig = ( pig .ge. ips_save+1        .and.      &
    3723. 

  3723.                             pjg .ge. jps_save+1        .and.      &
    3724. 

  3724.                             pig .le. ipe_save-1  +ioff .and.      &
    3725. 

  3725.                             pjg .le. jpe_save-1  +joff           )
    3726. 

  3726. 

  3727. END FUNCTION cd_feedback_mask_orig
    3728. 

  3728. 

  3729. LOGICAL FUNCTION cd_feedback_mask( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, xstag, ystag )
    3730. 

  3730.    INTEGER, INTENT(IN) :: pig, ips_save, ipe_save , pjg, jps_save, jpe_save
    3731. 

  3731.    LOGICAL, INTENT(IN) :: xstag, ystag
    3732. 

  3732. 

  3733.    INTEGER ioff, joff
    3734. 

  3734. 

  3735.    ioff = 0 ; joff = 0
    3736. 

  3736.    IF ( xstag  ) ioff = 1
    3737. 

  3737.    IF ( ystag  ) joff = 1
    3738. 

  3738. 

  3739.    cd_feedback_mask = ( pig .ge. ips_save+1 .and. &
    3740. 

  3740.                             pjg .ge. jps_save+2 .and. &
    3741. 

  3741.                             pig .le. ipe_save-1-mod(pjg-jps_save,2) .and. &
    3742. 

  3742.                             pjg .le. jpe_save-2 )
    3743. 

  3743. 

  3744. END FUNCTION cd_feedback_mask
    3745. 

  3745. 

  3746. LOGICAL FUNCTION cd_feedback_mask_v( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, xstag, ystag )
    3747. 

  3747.    INTEGER, INTENT(IN) :: pig, ips_save, ipe_save , pjg, jps_save, jpe_save
    3748. 

  3748.    LOGICAL, INTENT(IN) :: xstag, ystag
    3749. 

  3749. 

  3750.    INTEGER ioff, joff
    3751. 

  3751. 

  3752.    ioff = 0 ; joff = 0
    3753. 

  3753.    IF ( xstag  ) ioff = 1
    3754. 

  3754.    IF ( ystag  ) joff = 1
    3755. 

  3755.    
    3756. 

  3756.    cd_feedback_mask_v = ( pig .ge. ips_save+1 .and. &
    3757. 

  3757.                             pjg .ge. jps_save+2 .and. &
    3758. 

  3758.                             pig .le. ipe_save-1-mod(pjg-jps_save+1,2) .and. &
    3759. 

  3759.                             pjg .le. jpe_save-2 )
    3760. 

  3760. 

  3761. END FUNCTION cd_feedback_mask_v
    3762. 

  3762. 

  3763. 

  3764. !----------------------------------------------------------------------------
    3765. 

  3765. #else
    3766. 

  3766. SUBROUTINE stub_nmm_nest_stub
    3767. 

  3767. END SUBROUTINE stub_nmm_nest_stub
    3768. 

  3768. #endif
    3769. 

  3769. 

  3770. RECURSIVE SUBROUTINE find_ijstart_level ( grid, i_start, j_start, level )
    3771. 

  3771. 

  3772. ! Dusan Jovic
    3773. 

  3773. 

  3774.    USE module_domain
    3775. 

  3775. 

  3776.    IMPLICIT NONE
    3777. 

  3777. 

  3778.    !  Input data.
    3779. 

  3779. 

  3780.    TYPE(domain) :: grid
    3781. 

  3781.    INTEGER, INTENT (OUT) :: i_start, j_start, level
    3782. 

  3782.    INTEGER :: iadd
    3783. 

  3783. 

  3784.       if (grid%parent_id == 0 ) then
    3785. 

  3785.          i_start = 1
    3786. 

  3786.          j_start = 1
    3787. 

  3787.          level = 0
    3788. 

  3788.       else
    3789. 

  3789.          call find_ijstart_level ( grid%parents(1)%ptr, i_start, j_start, level )
    3790. 

  3790.          if (level > 0) then
    3791. 

  3791.              iadd = (i_start-1)*3
    3792. 

  3792.              if ( mod(j_start,2).ne.0 .and. mod(grid%j_parent_start,2).ne.0 ) iadd = iadd - 1
    3793. 

  3793.              if ( mod(j_start,2).eq.0 .and. mod(grid%j_parent_start,2).eq.0 ) iadd = iadd + 2
    3794. 

  3794.          else
    3795. 

  3795.              iadd = -mod(grid%j_parent_start,2)
    3796. 

  3796.          end if
    3797. 

  3797.          i_start = iadd + grid%i_parent_start*3 - 1
    3798. 

  3798.          j_start = ( (j_start-1) + (grid%j_parent_start-1) ) * 3 + 1
    3799. 

  3799.          level = level + 1
    3800. 

  3800.       end if
    3801. 

  3801. 

  3802. END SUBROUTINE find_ijstart_level
    3803. 

  3803.