PageRenderTime 47ms CodeModel.GetById 18ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/share/module_soil_pre.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 4250 lines | 3067 code | 692 blank | 491 comment | 30 complexity | 9a91b75be6fa25ff4e561715c40b39be MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1. #if ( ! NMM_CORE == 1 )
    2. 

  2. 

  3. MODULE module_soil_pre
    4. 

  4. 

  5.    USE module_date_time
    6. 

  6.    USE module_state_description
    7. 

  7. 

  8.    CHARACTER (LEN=3) :: num_cat_count
    9. 

  9.    INTEGER , PARAMETER , DIMENSION(0:300) :: ints = &
    10. 

  10.    (/    0,    1,    2,    3,    4,    5,    6,    7,    8,    9, &
    11. 

  11.         10,   11,   12,   13,   14,   15,   16,   17,   18,   19, &
    12. 

  12.         20,   21,   22,   23,   24,   25,   26,   27,   28,   29, &
    13. 

  13.         30,   31,   32,   33,   34,   35,   36,   37,   38,   39, &
    14. 

  14.         40,   41,   42,   43,   44,   45,   46,   47,   48,   49, &
    15. 

  15.         50,   51,   52,   53,   54,   55,   56,   57,   58,   59, &
    16. 

  16.         60,   61,   62,   63,   64,   65,   66,   67,   68,   69, &
    17. 

  17.         70,   71,   72,   73,   74,   75,   76,   77,   78,   79, &
    18. 

  18.         80,   81,   82,   83,   84,   85,   86,   87,   88,   89, &
    19. 

  19.         90,   91,   92,   93,   94,   95,   96,   97,   98,   99, &
    20. 

  20.        100,  101,  102,  103,  104,  105,  106,  107,  108,  109, &
    21. 

  21.        110,  111,  112,  113,  114,  115,  116,  117,  118,  119, &
    22. 

  22.        120,  121,  122,  123,  124,  125,  126,  127,  128,  129, &
    23. 

  23.        130,  131,  132,  133,  134,  135,  136,  137,  138,  139, &
    24. 

  24.        140,  141,  142,  143,  144,  145,  146,  147,  148,  149, &
    25. 

  25.        150,  151,  152,  153,  154,  155,  156,  157,  158,  159, &
    26. 

  26.        160,  161,  162,  163,  164,  165,  166,  167,  168,  169, &
    27. 

  27.        170,  171,  172,  173,  174,  175,  176,  177,  178,  179, &
    28. 

  28.        180,  181,  182,  183,  184,  185,  186,  187,  188,  189, &
    29. 

  29.        190,  191,  192,  193,  194,  195,  196,  197,  198,  199, &
    30. 

  30.        200,  201,  202,  203,  204,  205,  206,  207,  208,  209, &
    31. 

  31.        210,  211,  212,  213,  214,  215,  216,  217,  218,  219, &
    32. 

  32.        220,  221,  222,  223,  224,  225,  226,  227,  228,  229, &
    33. 

  33.        230,  231,  232,  233,  234,  235,  236,  237,  238,  239, &
    34. 

  34.        240,  241,  242,  243,  244,  245,  246,  247,  248,  249, &
    35. 

  35.        250,  251,  252,  253,  254,  255,  256,  257,  258,  259, &
    36. 

  36.        260,  261,  262,  263,  264,  265,  266,  267,  268,  269, &
    37. 

  37.        270,  271,  272,  273,  274,  275,  276,  277,  278,  279, &
    38. 

  38.        280,  281,  282,  283,  284,  285,  286,  287,  288,  289, &
    39. 

  39.        290,  291,  292,  293,  294,  295,  296,  297,  298,  299, 300 /)
    40. 

  40. 

  41.    !  Excluded middle processing
    42. 

  42. 

  43.    LOGICAL , SAVE :: hold_ups
    44. 

  44.    INTEGER , SAVE :: em_width
    45. 

  45. 

  46.    LOGICAL , EXTERNAL :: skip_middle_points_t
    47. 

  47. 

  48. CONTAINS
    49. 

  49. 

  50.    SUBROUTINE adjust_for_seaice_pre ( xice , landmask , tsk , ivgtyp , vegcat , lu_index , &
    51. 

  51.                                       xland , landusef , isltyp , soilcat , soilctop , &
    52. 

  52.                                       soilcbot , tmn , &
    53. 

  53.                                       seaice_threshold , &
    54. 

  54.                                       fractional_seaice, &
    55. 

  55.                                       num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
    56. 

  56.                                       iswater , isice , &
    57. 

  57.                                       scheme , &
    58. 

  58.                                       ids , ide , jds , jde , kds , kde , &
    59. 

  59.                                       ims , ime , jms , jme , kms , kme , &
    60. 

  60.                                       its , ite , jts , jte , kts , kte )
    61. 

  61. 

  62.       IMPLICIT NONE
    63. 

  63. 

  64.       INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
    65. 

  65.                               ims , ime , jms , jme , kms , kme , &
    66. 

  66.                               its , ite , jts , jte , kts , kte , &
    67. 

  67.                               iswater , isice
    68. 

  68.       INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat , scheme
    69. 

  69. 

  70.       REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landusef
    71. 

  71.       REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(INOUT):: soilctop
    72. 

  72.       REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(INOUT):: soilcbot
    73. 

  73.       INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp
    74. 

  74.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask , xice , tsk , lu_index , &
    75. 

  75.                                                            vegcat, xland , soilcat , tmn
    76. 

  76.       REAL , INTENT(IN) :: seaice_threshold
    77. 

  77. 

  78.       INTEGER :: i , j , num_seaice_changes , loop
    79. 

  79.       CHARACTER (LEN=132) :: message
    80. 

  80. 

  81.       INTEGER, INTENT(IN) :: fractional_seaice
    82. 

  82.       REAL :: XICE_THRESHOLD
    83. 

  83. 

  84.       IF ( FRACTIONAL_SEAICE == 0 ) THEN
    85. 

  85.          xice_threshold = 0.5
    86. 

  86.       ELSEIF ( FRACTIONAL_SEAICE == 1 ) THEN
    87. 

  87.          xice_threshold = 0.02
    88. 

  88.       ENDIF
    89. 

  89. 

  90.       num_seaice_changes = 0
    91. 

  91.       fix_seaice : SELECT CASE ( scheme )
    92. 

  92. 

  93.          CASE ( SLABSCHEME )
    94. 

  94.             DO j = jts , MIN(jde-1,jte)
    95. 

  95.                DO i = its , MIN(ide-1,ite)
    96. 

  96.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    97. 

  97.                   IF ( xice(i,j) .GT. 200.0 ) THEN
    98. 

  98.                      xice(i,j) = 0.
    99. 

  99.                      num_seaice_changes = num_seaice_changes + 1
    100. 

  100.                   END IF
    101. 

  101.                END DO
    102. 

  102.             END DO
    103. 

  103.             IF ( num_seaice_changes .GT. 0 ) THEN
    104. 

  104.                WRITE ( message , FMT='(A,I6)' ) &
    105. 

  105.                'Total pre number of sea ice locations removed (due to FLAG values) = ', &
    106. 

  106.                num_seaice_changes
    107. 

  107.                CALL wrf_debug ( 0 , message )
    108. 

  108.             END IF
    109. 

  109.             num_seaice_changes = 0
    110. 

  110.             DO j = jts , MIN(jde-1,jte)
    111. 

  111.                DO i = its , MIN(ide-1,ite)
    112. 

  112.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    113. 

  113.                   IF ( ( xice(i,j) .GE. xice_threshold ) .OR. &
    114. 

  114.                        ( ( landmask(i,j) .LT. 0.5 ) .AND. ( tsk(i,j) .LT. seaice_threshold ) ) ) THEN
    115. 

  115.                      IF ( FRACTIONAL_SEAICE == 0 ) THEN
    116. 

  116.                         xice(i,j) = 1.0
    117. 

  117.                      ENDIF
    118. 

  118.                      num_seaice_changes = num_seaice_changes + 1
    119. 

  119.                      if(landmask(i,j) .LT. 0.5 )tmn(i,j) = 271.4
    120. 

  120.                      vegcat(i,j)=isice
    121. 

  121.                      ivgtyp(i,j)=isice
    122. 

  122.                      lu_index(i,j)=isice
    123. 

  123.                      landmask(i,j)=1.
    124. 

  124.                      xland(i,j)=1.
    125. 

  125.                      DO loop=1,num_veg_cat
    126. 

  126.                         landusef(i,loop,j)=0.
    127. 

  127.                      END DO
    128. 

  128.                      landusef(i,ivgtyp(i,j),j)=1.
    129. 

  129. 

  130.                      isltyp(i,j) = 16
    131. 

  131.                      soilcat(i,j)=isltyp(i,j)
    132. 

  132.                      DO loop=1,num_soil_top_cat
    133. 

  133.                         soilctop(i,loop,j)=0
    134. 

  134.                      END DO
    135. 

  135.                      DO loop=1,num_soil_bot_cat
    136. 

  136.                         soilcbot(i,loop,j)=0
    137. 

  137.                      END DO
    138. 

  138.                      soilctop(i,isltyp(i,j),j)=1.
    139. 

  139.                      soilcbot(i,isltyp(i,j),j)=1.
    140. 

  140.                   ELSE
    141. 

  141.                      xice(i,j) = 0.0
    142. 

  142.                   END IF
    143. 

  143.                END DO
    144. 

  144.             END DO
    145. 

  145.             IF ( num_seaice_changes .GT. 0 ) THEN
    146. 

  146.                WRITE ( message , FMT='(A,I6)' ) &
    147. 

  147.                'Total pre number of sea ice location changes (water to land) = ', num_seaice_changes
    148. 

  148.                CALL wrf_debug ( 0 , message )
    149. 

  149.             END IF
    150. 

  150. 

  151.          CASE ( LSMSCHEME , NOAHMPSCHEME , RUCLSMSCHEME , SSIBSCHEME)   !mchen add for ssib
    152. 

  152.             num_seaice_changes = 0
    153. 

  153.             DO j = jts , MIN(jde-1,jte)
    154. 

  154.                DO i = its , MIN(ide-1,ite)
    155. 

  155.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    156. 

  156.                   IF ( landmask(i,j) .GT. 0.5 ) THEN
    157. 

  157.                      if (xice(i,j).gt.0) num_seaice_changes = num_seaice_changes + 1
    158. 

  158.                      xice(i,j) = 0.
    159. 

  159.                   END IF
    160. 

  160.                END DO
    161. 

  161.             END DO
    162. 

  162.             IF ( num_seaice_changes .GT. 0 ) THEN
    163. 

  163.                WRITE ( message , FMT='(A,I6)' ) &
    164. 

  164.                'Total pre number of land location changes (seaice set to zero) = ', num_seaice_changes
    165. 

  165.                CALL wrf_debug ( 0 , message )
    166. 

  166.             END IF
    167. 

  167. 

  168.       END SELECT fix_seaice
    169. 

  169. 

  170.    END SUBROUTINE adjust_for_seaice_pre
    171. 

  171. 

  172.    SUBROUTINE adjust_for_seaice_post ( xice , landmask , tsk_old , tsk , ivgtyp , vegcat , lu_index , &
    173. 

  173.                                       xland , landusef , isltyp , soilcat , soilctop , &
    174. 

  174.                                       soilcbot , tmn , vegfra , &
    175. 

  175.                                       tslb , smois , sh2o , &
    176. 

  176.                                       seaice_threshold , &
    177. 

  177.                                       sst , flag_sst , &
    178. 

  178.                                       fractional_seaice, &
    179. 

  179.                                       num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
    180. 

  180.                                       num_soil_layers , &
    181. 

  181.                                       iswater , isice , &
    182. 

  182.                                       scheme , &
    183. 

  183.                                       ids , ide , jds , jde , kds , kde , &
    184. 

  184.                                       ims , ime , jms , jme , kms , kme , &
    185. 

  185.                                       its , ite , jts , jte , kts , kte )
    186. 

  186. 

  187.       IMPLICIT NONE
    188. 

  188. 

  189.       INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
    190. 

  190.                               ims , ime , jms , jme , kms , kme , &
    191. 

  191.                               its , ite , jts , jte , kts , kte , &
    192. 

  192.                               iswater , isice
    193. 

  193.       INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat , scheme
    194. 

  194.       INTEGER , INTENT(IN) :: num_soil_layers
    195. 

  195. 

  196.       REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landusef
    197. 

  197.       REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(INOUT):: soilctop
    198. 

  198.       REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(INOUT):: soilcbot
    199. 

  199.       REAL , DIMENSION(ims:ime,1:num_soil_layers,jms:jme) , INTENT(INOUT):: tslb , smois , sh2o
    200. 

  200.       REAL , DIMENSION(ims:ime,jms:jme)                   , INTENT(IN):: sst
    201. 

  201.       INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp
    202. 

  202.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask , xice , tsk , lu_index , &
    203. 

  203.                                                            vegcat, xland , soilcat , tmn , &
    204. 

  204.                                                            tsk_old , vegfra
    205. 

  205.       INTEGER , INTENT(IN) :: flag_sst
    206. 

  206.       REAL , INTENT(IN) :: seaice_threshold
    207. 

  207.       REAL :: total_depth , mid_point_depth
    208. 

  208. 

  209.       INTEGER :: i , j , num_seaice_changes , loop
    210. 

  210.       CHARACTER (LEN=132) :: message
    211. 

  211. 

  212. 

  213.       INTEGER, INTENT(IN) :: fractional_seaice
    214. 

  214.       real :: xice_threshold
    215. 

  215. 

  216.       IF ( FRACTIONAL_SEAICE == 0 ) THEN
    217. 

  217.          xice_threshold = 0.5
    218. 

  218.       ELSEIF ( FRACTIONAL_SEAICE == 1 ) THEN
    219. 

  219.          xice_threshold = 0.02
    220. 

  220.       ENDIF
    221. 

  221.       num_seaice_changes = 0
    222. 

  222.       fix_seaice : SELECT CASE ( scheme )
    223. 

  223. 

  224.          CASE ( SLABSCHEME )
    225. 

  225. 

  226.          CASE ( LSMSCHEME , NOAHMPSCHEME , SSIBSCHEME )   !mchen add for ssib
    227. 

  227.             DO j = jts , MIN(jde-1,jte)
    228. 

  228.                DO i = its , MIN(ide-1,ite)
    229. 

  229.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    230. 

  230.                   IF ( xice(i,j) .GT. 200.0 ) THEN
    231. 

  231.                      xice(i,j) = 0.
    232. 

  232.                      num_seaice_changes = num_seaice_changes + 1
    233. 

  233.                   END IF
    234. 

  234.                END DO
    235. 

  235.             END DO
    236. 

  236.             IF ( num_seaice_changes .GT. 0 ) THEN
    237. 

  237.                WRITE ( message , FMT='(A,I6)' ) &
    238. 

  238.                'Total post number of sea ice locations removed (due to FLAG values) = ', &
    239. 

  239.                num_seaice_changes
    240. 

  240.                CALL wrf_debug ( 0 , message )
    241. 

  241.             END IF
    242. 

  242.             num_seaice_changes = 0
    243. 

  243.             DO j = jts , MIN(jde-1,jte)
    244. 

  244.                DO i = its , MIN(ide-1,ite)
    245. 

  245.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    246. 

  246.                   IF ( ( ( tsk(i,j) .LT. 170 ) .OR. ( tsk(i,j) .GT. 400 ) ) .AND. &
    247. 

  247.                        ( ( tsk_old(i,j) .GT. 170 ) .AND. ( tsk_old(i,j) .LT. 400 ) ) )THEN
    248. 

  248.                      tsk(i,j) = tsk_old(i,j)
    249. 

  249.                   END IF
    250. 

  250.                   IF ( ( ( tsk(i,j) .LT. 170 ) .OR. ( tsk(i,j) .GT. 400 ) ) .AND. &
    251. 

  251.                        ( ( tsk_old(i,j) .LT. 170 ) .OR. ( tsk_old(i,j) .GT. 400 ) ) )THEN
    252. 

  252.                      print *,'TSK woes in seaice post, i,j=',i,j,'  tsk = ',tsk(i,j), tsk_old(i,j)
    253. 

  253.                      CALL wrf_error_fatal ( 'TSK is unrealistic, problems for seaice post')
    254. 

  254.                   ELSE IF ( ( xice(i,j) .GE. xice_threshold ) .OR. &
    255. 

  255.                        ( ( landmask(i,j) .LT. 0.5 ) .AND. ( tsk(i,j) .LT. seaice_threshold ) ) ) THEN
    256. 

  256.                      IF ( FRACTIONAL_SEAICE == 0 ) THEN
    257. 

  257.                         xice(i,j) = 1.0
    258. 

  258.                      ENDIF
    259. 

  259.                      num_seaice_changes = num_seaice_changes + 1
    260. 

  260.                      if(landmask(i,j) .LT. 0.5 )tmn(i,j) = 271.4
    261. 

  261.                      vegcat(i,j)=isice
    262. 

  262.                      ivgtyp(i,j)=isice
    263. 

  263.                      lu_index(i,j)=isice
    264. 

  264.                      landmask(i,j)=1.
    265. 

  265.                      xland(i,j)=1.
    266. 

  266.                      vegfra(i,j)=0.
    267. 

  267.                      DO loop=1,num_veg_cat
    268. 

  268.                         landusef(i,loop,j)=0.
    269. 

  269.                      END DO
    270. 

  270.                      landusef(i,ivgtyp(i,j),j)=1.
    271. 

  271. 

  272.                      tsk_old(i,j) = tsk(i,j)
    273. 

  273. 

  274.                      isltyp(i,j) = 16
    275. 

  275.                      soilcat(i,j)=isltyp(i,j)
    276. 

  276.                      DO loop=1,num_soil_top_cat
    277. 

  277.                         soilctop(i,loop,j)=0
    278. 

  278.                      END DO
    279. 

  279.                      DO loop=1,num_soil_bot_cat
    280. 

  280.                         soilcbot(i,loop,j)=0
    281. 

  281.                      END DO
    282. 

  282.                      soilctop(i,isltyp(i,j),j)=1.
    283. 

  283.                      soilcbot(i,isltyp(i,j),j)=1.
    284. 

  284. 

  285.                      total_depth = 3. ! ice is 3 m deep, num_soil_layers equispaced layers
    286. 

  286.                      DO loop = 1,num_soil_layers
    287. 

  287.                         mid_point_depth=(total_depth/num_soil_layers)/2. + &
    288. 

  288.                                         (loop-1)*(total_depth/num_soil_layers)
    289. 

  289.                         tslb(i,loop,j) = ( (total_depth-mid_point_depth)*tsk(i,j) + &
    290. 

  290.                                             mid_point_depth*tmn(i,j) ) / total_depth
    291. 

  291.                      END DO
    292. 

  292. 

  293.                      DO loop=1,num_soil_layers
    294. 

  294.                         smois(i,loop,j) = 1.0
    295. 

  295.                         sh2o(i,loop,j)  = 0.0
    296. 

  296.                      END DO
    297. 

  297.                   ELSE IF ( xice(i,j) .LT. xice_threshold ) THEN
    298. 

  298.                      xice(i,j) = 0.
    299. 

  299.                   END IF
    300. 

  300.                END DO
    301. 

  301.             END DO
    302. 

  302.             IF ( num_seaice_changes .GT. 0 ) THEN
    303. 

  303.                WRITE ( message , FMT='(A,I6)' ) &
    304. 

  304.                'Total post number of sea ice location changes (water to land) = ', num_seaice_changes
    305. 

  305.                CALL wrf_debug ( 0 , message )
    306. 

  306.             END IF
    307. 

  307. 

  308.         CASE ( RUCLSMSCHEME )
    309. 

  309.             DO j = jts , MIN(jde-1,jte)
    310. 

  310.                DO i = its , MIN(ide-1,ite)
    311. 

  311.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    312. 

  312.                   IF ( xice(i,j) .GT. 200.0 ) THEN
    313. 

  313.                      xice(i,j) = 0.
    314. 

  314.                      num_seaice_changes = num_seaice_changes + 1
    315. 

  315.                   END IF
    316. 

  316.                END DO
    317. 

  317.             END DO
    318. 

  318.             IF ( num_seaice_changes .GT. 0 ) THEN
    319. 

  319.                WRITE ( message , FMT='(A,I6)' ) &
    320. 

  320.                'Total post number of sea ice locations removed (due to FLAG values) = ', &
    321. 

  321.                num_seaice_changes
    322. 

  322.                CALL wrf_debug ( 0 , message )
    323. 

  323.             END IF
    324. 

  324.             num_seaice_changes = 0
    325. 

  325.             DO j = jts , MIN(jde-1,jte)
    326. 

  326.                DO i = its , MIN(ide-1,ite)
    327. 

  327.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    328. 

  328.                   IF ( ( ( tsk(i,j) .LT. 170 ) .OR. ( tsk(i,j) .GT. 400 ) ) .AND. &
    329. 

  329.                        ( ( tsk_old(i,j) .GT. 170 ) .AND. ( tsk_old(i,j) .LT. 400 ) ) )THEN
    330. 

  330.                      tsk(i,j) = tsk_old(i,j)
    331. 

  331.                   END IF
    332. 

  332.                   IF ( ( ( tsk(i,j) .LT. 170 ) .OR. ( tsk(i,j) .GT. 400 ) ) .AND. &
    333. 

  333.                        ( ( tsk_old(i,j) .LT. 170 ) .OR. ( tsk_old(i,j) .GT. 400 ) ) )THEN
    334. 

  334.                      print *,'TSK woes in seaice post, i,j=',i,j,'  tsk = ',tsk(i,j), tsk_old(i,j)
    335. 

  335.                      CALL wrf_error_fatal ( 'TSK is unrealistic, problems for seaice post')
    336. 

  336.                   ELSE IF ( ( xice(i,j) .GE. xice_threshold ) .OR. &
    337. 

  337.                        ( ( landmask(i,j) .LT. 0.5 ) .AND. ( tsk(i,j) .LT. seaice_threshold ) ) ) THEN
    338. 

  338.                        IF ( FRACTIONAL_SEAICE == 0 ) THEN
    339. 

  339.                           xice(i,j) = 1.0
    340. 

  340.                        ELSE
    341. 

  341.                           xice(i,j)=max(0.25,xice(i,j))
    342. 

  342.                        ENDIF
    343. 

  343.                      num_seaice_changes = num_seaice_changes + 1
    344. 

  344.                      if(landmask(i,j) .LT. 0.5 )tmn(i,j) = 271.4
    345. 

  345.                      vegcat(i,j)=isice
    346. 

  346.                      ivgtyp(i,j)=isice
    347. 

  347.                      lu_index(i,j)=isice
    348. 

  348.                      landmask(i,j)=1.
    349. 

  349.                      xland(i,j)=1.
    350. 

  350.                      vegfra(i,j)=0.
    351. 

  351.                      DO loop=1,num_veg_cat
    352. 

  352.                         landusef(i,loop,j)=0.
    353. 

  353.                      END DO
    354. 

  354.                      landusef(i,ivgtyp(i,j),j)=1.
    355. 

  355. 

  356. !tgs - compute blended sea ice/water skin temperature
    357. 

  357.                    if(flag_sst.eq.1) then
    358. 

  358.                      tsk(i,j) = xice(i,j)*(min(seaice_threshold,tsk(i,j)))  &
    359. 

  359.                                 +(1-xice(i,j))*sst(i,j)
    360. 

  360.                    else
    361. 

  361.                      tsk(i,j) = xice(i,j)*(min(seaice_threshold,tsk(i,j)))  &
    362. 

  362.                                 +(1-xice(i,j))*tsk(i,j)
    363. 

  363.                    endif
    364. 

  364.                      tsk_old(i,j) = tsk(i,j)
    365. 

  365. 

  366.                      isltyp(i,j) = 16
    367. 

  367.                      soilcat(i,j)=isltyp(i,j)
    368. 

  368.                      DO loop=1,num_soil_top_cat
    369. 

  369.                         soilctop(i,loop,j)=0
    370. 

  370.                      END DO
    371. 

  371.                      DO loop=1,num_soil_bot_cat
    372. 

  372.                         soilcbot(i,loop,j)=0
    373. 

  373.                      END DO
    374. 

  374.                      soilctop(i,isltyp(i,j),j)=1.
    375. 

  375.                      soilcbot(i,isltyp(i,j),j)=1.
    376. 

  376. 

  377.                  total_depth = 3. ! ice is 3 m deep, num_soil_layers equispaced layers
    378. 

  378.                        tslb(i,1,j) = tsk(i,j)
    379. 

  379.                        tslb(i,num_soil_layers,j) = tmn(i,j)
    380. 

  380.                      DO loop = 2,num_soil_layers-1
    381. 

  381.                         mid_point_depth=(total_depth/num_soil_layers)/4. + &
    382. 

  382.                                         (loop-2)*(total_depth/num_soil_layers)
    383. 

  383.                         tslb(i,loop,j) = ( (total_depth-mid_point_depth)*tsk(i,j) + &
    384. 

  384.                                             mid_point_depth*tmn(i,j) ) / total_depth
    385. 

  385.                      END DO
    386. 

  386. 

  387.                      DO loop=1,num_soil_layers
    388. 

  388.                         smois(i,loop,j) = 1.0
    389. 

  389.                         sh2o(i,loop,j)  = 0.0
    390. 

  390.                      END DO
    391. 

  391.                   ELSE IF ( xice(i,j) .LT. xice_threshold ) THEN
    392. 

  392.                      xice(i,j) = 0.
    393. 

  393.                   END IF
    394. 

  394.                END DO
    395. 

  395.             END DO
    396. 

  396.             IF ( num_seaice_changes .GT. 0 ) THEN
    397. 

  397.                WRITE ( message , FMT='(A,I6)' ) &
    398. 

  398.                'Total post number of sea ice location changes (water to land) = ', num_seaice_changes
    399. 

  399.                CALL wrf_debug ( 0 , message )
    400. 

  400.             END IF
    401. 

  401. 

  402. 

  403.       END SELECT fix_seaice
    404. 

  404. 

  405.    END SUBROUTINE adjust_for_seaice_post
    406. 

  406. 

  407.    SUBROUTINE process_percent_cat_new ( landmask ,  &
    408. 

  408.                                 landuse_frac , soil_top_cat , soil_bot_cat , &
    409. 

  409.                                 isltyp , ivgtyp , &
    410. 

  410.                                 num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
    411. 

  411.                                 ids , ide , jds , jde , kds , kde , &
    412. 

  412.                                 ims , ime , jms , jme , kms , kme , &
    413. 

  413.                                 its , ite , jts , jte , kts , kte , &
    414. 

  414.                                 iswater )
    415. 

  415. 

  416.       IMPLICIT NONE
    417. 

  417. 

  418.       INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
    419. 

  419.                               ims , ime , jms , jme , kms , kme , &
    420. 

  420.                               its , ite , jts , jte , kts , kte , &
    421. 

  421.                               iswater
    422. 

  422.       INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
    423. 

  423.       REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landuse_frac
    424. 

  424.       REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(IN):: soil_top_cat
    425. 

  425.       REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(IN):: soil_bot_cat
    426. 

  426.       INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp
    427. 

  427.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask
    428. 

  428. 

  429.       INTEGER :: i , j , l , ll, dominant_index
    430. 

  430.       REAL :: dominant_value
    431. 

  431. 

  432. #ifdef WRF_CHEM
    433. 

  433. !      REAL :: lwthresh = .99
    434. 

  434.       REAL :: lwthresh = .50
    435. 

  435. #else
    436. 

  436.       REAL :: lwthresh = .50
    437. 

  437. #endif
    438. 

  438. 

  439.       INTEGER , PARAMETER :: iswater_soil = 14
    440. 

  440.       INTEGER :: iforce
    441. 

  441.       CHARACTER (LEN=132) :: message
    442. 

  442.       CHARACTER(LEN=256) :: mminlu
    443. 

  443.       LOGICAL :: aggregate_lu
    444. 

  444. integer :: change_water , change_land
    445. 

  445. change_water = 0
    446. 

  446. change_land = 0
    447. 

  447. 

  448.       !  Sanity check on the 50/50 points
    449. 

  449. 

  450.       DO j = jts , MIN(jde-1,jte)
    451. 

  451.          DO i = its , MIN(ide-1,ite)
    452. 

  452.             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    453. 

  453.             dominant_value = landuse_frac(i,iswater,j)
    454. 

  454.             IF ( dominant_value .EQ. lwthresh ) THEN
    455. 

  455.                DO l = 1 , num_veg_cat
    456. 

  456.                   IF ( l .EQ. iswater ) CYCLE
    457. 

  457.                   IF ( ( landuse_frac(i,l,j) .EQ. lwthresh ) .AND. ( landmask(i,j) .LT. 0.5 ) ) THEN
    458. 

  458.                      PRINT *,i,j,' water and category ',l,' both at 50%, landmask is ',landmask(i,j)
    459. 

  459.                      landuse_frac(i,l,j) = lwthresh - .01
    460. 

  460.                      landuse_frac(i,iswater,j) = lwthresh + 0.01
    461. 

  461.                   ELSE IF ( ( landuse_frac(i,l,j) .EQ. lwthresh ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
    462. 

  462.                      PRINT *,i,j,' water and category ',l,' both at 50%, landmask is ',landmask(i,j)
    463. 

  463.                      landuse_frac(i,l,j) = lwthresh + .01
    464. 

  464.                      landuse_frac(i,iswater,j) = lwthresh - 0.01
    465. 

  465.                   END IF
    466. 

  466.                END DO
    467. 

  467.             END IF
    468. 

  468.          END DO
    469. 

  469.       END DO
    470. 

  470. 

  471.       !  Compute the aggregate of the vegetation/land use categories.  Lump all of the grasses together,
    472. 

  472.       !  all of the shrubs, all of the trees, etc.  Choose the correct set of available land use
    473. 

  473.       !  categories.  Also, make sure that the user wants to actually avail themselves of aforementioned
    474. 

  474.       !  opportunity, as mayhaps they don't.
    475. 

  475.  
    476. 

  476.       CALL nl_get_mminlu       ( 1 , mminlu       )
    477. 

  477.       CALL nl_get_aggregate_lu ( 1 , aggregate_lu )
    478. 

  478.       IF ( aggregate_lu ) THEN
    479. 

  479.          DO j = jts , MIN(jde-1,jte)
    480. 

  480.             DO i = its , MIN(ide-1,ite)
    481. 

  481.                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    482. 

  482.                CALL aggregate_categories_part1 ( landuse_frac , iswater , num_veg_cat , mminlu(1:4) )
    483. 

  483.             END DO
    484. 

  484.          END DO
    485. 

  485.       END IF
    486. 

  486. 

  487.       !  Compute the dominant VEGETATION INDEX.
    488. 

  488. 

  489.       DO j = jts , MIN(jde-1,jte)
    490. 

  490.          DO i = its , MIN(ide-1,ite)
    491. 

  491.             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    492. 

  492.             dominant_value = landuse_frac(i,1,j)
    493. 

  493.             dominant_index = 1
    494. 

  494.             DO l = 2 , num_veg_cat
    495. 

  495.                IF        ( l .EQ. iswater ) THEN
    496. 

  496.                   ! wait a bit
    497. 

  497.                ELSE IF ( ( l .NE. iswater ) .AND. ( landuse_frac(i,l,j) .GT. dominant_value ) ) THEN
    498. 

  498.                   dominant_value = landuse_frac(i,l,j)
    499. 

  499.                   dominant_index = l
    500. 

  500.                END IF
    501. 

  501.             END DO
    502. 

  502.             IF ( landuse_frac(i,iswater,j) .GT. lwthresh ) THEN
    503. 

  503.                dominant_value = landuse_frac(i,iswater,j)
    504. 

  504.                dominant_index = iswater
    505. 

  505.             ELSE IF ( ( landuse_frac(i,iswater,j) .EQ. lwthresh) .AND. &
    506. 

  506.                       ( landmask(i,j) .LT. 0.5) .AND. &
    507. 

  507.                       ( dominant_value .EQ. lwthresh) ) THEN
    508. 

  508.                dominant_value = landuse_frac(i,iswater,j)
    509. 

  509.                dominant_index = iswater
    510. 

  510.             ELSE IF ( ( landuse_frac(i,iswater,j) .EQ. lwthresh) .AND. &
    511. 

  511.                       ( landmask(i,j) .GT. 0.5) .AND. &
    512. 

  512.                       ( dominant_value .EQ. lwthresh) ) THEN
    513. 

  513.                !no op
    514. 

  514.             ELSE IF ( ( landuse_frac(i,iswater,j) .EQ. lwthresh ) .AND. &
    515. 

  515.                       ( dominant_value .LT. lwthresh ) ) THEN
    516. 

  516.                dominant_value = landuse_frac(i,iswater,j)
    517. 

  517.                dominant_index = iswater
    518. 

  518.             END IF
    519. 

  519.             IF      ( dominant_index .EQ. iswater ) THEN
    520. 

  520. if(landmask(i,j).gt.lwthresh) then
    521. 

  521. !print *,'changing to water at point ',i,j
    522. 

  522. !WRITE ( num_cat_count , FMT = '(I3)' ) num_veg_cat
    523. 

  523. !WRITE ( message , FMT = '('//num_cat_count//'(i3,1x))' ) ints(1:num_veg_cat)
    524. 

  524. !CALL wrf_debug(1,message)
    525. 

  525. !WRITE ( message , FMT = '('//num_cat_count//'(i3,1x))' ) nint(landuse_frac(i,:,j)*100)
    526. 

  526. !CALL wrf_debug(1,message)
    527. 

  527. change_water=change_water+1
    528. 

  528. endif
    529. 

  529.                landmask(i,j) = 0
    530. 

  530.             ELSE IF ( dominant_index .NE. iswater ) THEN
    531. 

  531. if(landmask(i,j).lt.lwthresh) then
    532. 

  532. !print *,'changing to land at point ',i,j
    533. 

  533. !WRITE ( num_cat_count , FMT = '(I3)' ) num_veg_cat
    534. 

  534. !WRITE ( message , FMT = '('//num_cat_count//'(i3,1x))' ) ints(1:num_veg_cat)
    535. 

  535. !CALL wrf_debug(1,message)
    536. 

  536. !WRITE ( message , FMT = '('//num_cat_count//'(i3,1x))' ) nint(landuse_frac(i,:,j)*100)
    537. 

  537. !CALL wrf_debug(1,message)
    538. 

  538. change_land=change_land+1
    539. 

  539. endif
    540. 

  540.                landmask(i,j) = 1
    541. 

  541.             END IF
    542. 

  542.             ivgtyp(i,j) = dominant_index
    543. 

  543.          END DO
    544. 

  544.       END DO
    545. 

  545. 

  546.       !  Compute the dominant SOIL TEXTURE INDEX, TOP.
    547. 

  547. 

  548.       iforce = 0
    549. 

  549.       DO i = its , MIN(ide-1,ite)
    550. 

  550.          DO j = jts , MIN(jde-1,jte)
    551. 

  551.             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    552. 

  552.             dominant_value = soil_top_cat(i,1,j)
    553. 

  553.             dominant_index = 1
    554. 

  554.             IF ( landmask(i,j) .GT. lwthresh ) THEN
    555. 

  555.                DO l = 2 , num_soil_top_cat
    556. 

  556.                   IF ( ( l .NE. iswater_soil ) .AND. ( soil_top_cat(i,l,j) .GT. dominant_value ) ) THEN
    557. 

  557.                      dominant_value = soil_top_cat(i,l,j)
    558. 

  558.                      dominant_index = l
    559. 

  559.                   END IF
    560. 

  560.                END DO
    561. 

  561.                IF ( dominant_value .LT. 0.01 ) THEN
    562. 

  562.                   iforce = iforce + 1
    563. 

  563.                   WRITE ( message , FMT = '(A,I4,I4)' ) &
    564. 

  564.                   'based on landuse, changing soil to land at point ',i,j
    565. 

  565.                   CALL wrf_debug(1,message)
    566. 

  566.                   WRITE ( num_cat_count , FMT = '(I3)' ) num_soil_top_cat
    567. 

  567.                   WRITE ( message , FMT = '('//num_cat_count//'(i3,1x))' ) (ints(l),l=1,num_soil_top_cat)
    568. 

  568.                   CALL wrf_debug(1,message)
    569. 

  569.                   WRITE ( message , FMT = '('//num_cat_count//'(i3,1x))' ) &
    570. 

  570.                     ((nint(soil_top_cat(i,ints(l),j)*100)), l=1,num_soil_top_cat)
    571. 

  571.                   CALL wrf_debug(1,message)
    572. 

  572.                   dominant_index = 8
    573. 

  573.                END IF
    574. 

  574.             ELSE
    575. 

  575.                dominant_index = iswater_soil
    576. 

  576.             END IF
    577. 

  577.             isltyp(i,j) = dominant_index
    578. 

  578.          END DO
    579. 

  579.       END DO
    580. 

  580. 

  581. if(iforce.ne.0)then
    582. 

  582. WRITE(message,FMT='(A,I4,A,I6)' ) &
    583. 

  583. 'forcing artificial silty clay loam at ',iforce,' points, out of ',&
    584. 

  584. (MIN(ide-1,ite)-its+1)*(MIN(jde-1,jte)-jts+1)
    585. 

  585. CALL wrf_debug(0,message)
    586. 

  586. endif
    587. 

  587. print *,'LAND  CHANGE = ',change_land
    588. 

  588. print *,'WATER CHANGE = ',change_water
    589. 

  589. 

  590.    END SUBROUTINE process_percent_cat_new
    591. 

  591. 

  592.    SUBROUTINE process_soil_real ( tsk , tmn , tavgsfc, &
    593. 

  593.                                 landmask , sst , ht, toposoil, &
    594. 

  594.                                 st_input , sm_input , sw_input , &
    595. 

  595.                                 st_levels_input , sm_levels_input , sw_levels_input , &
    596. 

  596.                                 zs , dzs , tslb , smois , sh2o , &
    597. 

  597.                                 flag_sst , flag_tavgsfc, flag_soilhgt, &
    598. 

  598.                                 flag_soil_layers, flag_soil_levels, &
    599. 

  599.                                 ids , ide , jds , jde , kds , kde , &
    600. 

  600.                                 ims , ime , jms , jme , kms , kme , &
    601. 

  601.                                 its , ite , jts , jte , kts , kte , &
    602. 

  602.                                 sf_surface_physics , num_soil_layers , real_data_init_type , &
    603. 

  603.                                 num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
    604. 

  604.                                 num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc )
    605. 

  605. 

  606.       IMPLICIT NONE
    607. 

  607. 

  608.       INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
    609. 

  609.                               ims , ime , jms , jme , kms , kme , &
    610. 

  610.                               its , ite , jts , jte , kts , kte , &
    611. 

  611.                               sf_surface_physics , num_soil_layers , real_data_init_type , &
    612. 

  612.                               num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
    613. 

  613.                               num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc
    614. 

  614. 

  615.       INTEGER , INTENT(IN) :: flag_sst, flag_tavgsfc
    616. 

  616.       INTEGER , INTENT(IN) :: flag_soil_layers, flag_soil_levels, flag_soilhgt
    617. 

  617. 

  618.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst
    619. 

  619. 

  620.       INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input
    621. 

  621.       INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input
    622. 

  622.       INTEGER , DIMENSION(1:num_sw_levels_input) , INTENT(INOUT) :: sw_levels_input
    623. 

  623.       REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input
    624. 

  624.       REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input
    625. 

  625.       REAL , DIMENSION(ims:ime,1:num_sw_levels_alloc,jms:jme) , INTENT(INOUT) :: sw_input
    626. 

  626. 

  627.       REAL, DIMENSION(1:num_soil_layers), INTENT(OUT)  ::  zs,dzs
    628. 

  628.       REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois , sh2o
    629. 

  629.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tavgsfc, ht, toposoil
    630. 

  630.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk, tmn
    631. 

  631. 

  632.       INTEGER :: i , j , k, l , dominant_index , num_soil_cat , num_veg_cat, closest_layer
    633. 

  633.       REAL :: dominant_value, closest_depth, diff_cm
    634. 

  634.       REAL , ALLOCATABLE , DIMENSION(:) :: depth     ! Soil layer thicknesses (cm)
    635. 

  635.       REAL, PARAMETER :: get_temp_closest_to = 30.   ! use soil temperature closest to this depth (cm)
    636. 

  636.       REAL, PARAMETER :: something_big = 1.e6        ! Initialize closest depth as something big (cm)
    637. 

  637.       INTEGER :: something_far = 1000                ! Soil array index far away
    638. 

  638.       CHARACTER (LEN=132) :: message
    639. 

  639. 

  640.       !  Case statement for tmn initialization
    641. 

  641.       !  Need to have a reasonable default value for annual mean deeeeep soil temperature
    642. 

  642.       !  For sf_surface_physics = 1, we want to use close to a 30 cm value
    643. 

  643.       !  for the bottom level of the soil temps.
    644. 

  644.       ! NOTE:  We are assuming that soil_layers are the same for each grid point
    645. 

  645. 

  646.       fix_bottom_level_for_temp : SELECT CASE ( sf_surface_physics )
    647. 

  647.          CASE (SLABSCHEME)
    648. 

  648.             IF ( flag_tavgsfc  .EQ. 1 ) THEN
    649. 

  649.                CALL wrf_debug ( 0 , 'Using average surface temperature for tmn')
    650. 

  650.                DO j = jts , MIN(jde-1,jte)
    651. 

  651.                   DO i = its , MIN(ide-1,ite)
    652. 

  652.                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    653. 

  653.                      tmn(i,j) = tavgsfc(i,j)
    654. 

  654.                   END DO
    655. 

  655.                END DO
    656. 

  656.             ELSE
    657. 

  657.             ! Look for soil temp close to 30 cm
    658. 

  658.                closest_layer = something_far
    659. 

  659.                closest_depth = something_big
    660. 

  660.                DO k = 1, num_st_levels_input
    661. 

  661.                   diff_cm = abs( st_levels_input(k) - get_temp_closest_to )
    662. 

  662.                   IF ( diff_cm < closest_depth ) THEN
    663. 

  663.                      closest_depth = diff_cm
    664. 

  664.                      closest_layer = k
    665. 

  665.                   END IF
    666. 

  666.                END DO
    667. 

  667.                IF ( closest_layer == something_far ) THEN
    668. 

  668.                   CALL wrf_debug ( 0 , 'No soil temperature data for grid%tmn near 30 cm')
    669. 

  669.                   CALL wrf_debug ( 0 , 'Using 1 degree static annual mean temps' )
    670. 

  670.                ELSE
    671. 

  671.                   write(message, FMT='(A,F7.2,A,I3)')&
    672. 

  672.                      'Soil temperature closest to ',get_temp_closest_to, &
    673. 

  673.                      ' at level ',st_levels_input(closest_layer)
    674. 

  674.                   CALL wrf_debug ( 0 , message )
    675. 

  675.                   DO j = jts , MIN(jde-1,jte)
    676. 

  676.                      DO i = its , MIN(ide-1,ite)
    677. 

  677.                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    678. 

  678.                         tmn(i,j) = st_input(i,closest_layer+1,j)
    679. 

  679.                      END DO
    680. 

  680.                   END DO
    681. 

  681.                END IF
    682. 

  682.             END IF
    683. 

  683. 

  684.          CASE (LSMSCHEME)
    685. 

  685. 

  686.          CASE (NOAHMPSCHEME)
    687. 

  687. 

  688.          CASE (RUCLSMSCHEME)
    689. 

  689. 

  690.          CASE (PXLSMSCHEME)
    691. 

  691. ! When the input data from met_em is in layers, there is an additional level added to the beginning
    692. 

  692. ! of the array to define the surface, which is why we add the extra value (closest_layer+1)
    693. 

  693.             IF ( flag_tavgsfc  .EQ. 1 ) THEN
    694. 

  694.                CALL wrf_debug ( 0 , 'Using average surface temperature for tmn')
    695. 

  695.                DO j = jts , MIN(jde-1,jte)
    696. 

  696.                   DO i = its , MIN(ide-1,ite)
    697. 

  697.                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    698. 

  698.                      tmn(i,j) = tavgsfc(i,j)
    699. 

  699.                   END DO
    700. 

  700.                END DO
    701. 

  701.             ELSE
    702. 

  702.             ! Look for soil temp close to 30 cm
    703. 

  703.                closest_layer = num_st_levels_input+1
    704. 

  704.                closest_depth = something_big
    705. 

  705.                DO k = 1, num_st_levels_input
    706. 

  706.                   diff_cm = abs( st_levels_input(k) - get_temp_closest_to )
    707. 

  707.                   IF ( diff_cm < closest_depth ) THEN
    708. 

  708.                      closest_depth = diff_cm
    709. 

  709.                      closest_layer = k
    710. 

  710.                   END IF
    711. 

  711.                END DO
    712. 

  712.                IF ( closest_layer == num_st_levels_input + 1 ) THEN
    713. 

  713.                   CALL wrf_debug ( 0 , 'No soil temperature data for grid%tmn near 30 cm')
    714. 

  714.                   CALL wrf_debug ( 0 , 'Using 1 degree static annual mean temps' )
    715. 

  715.                ELSE
    716. 

  716.                   write(message, FMT='(A,F7.2,A,I3)')&
    717. 

  717.                      'Soil temperature closest to ',get_temp_closest_to, &
    718. 

  718.                      ' at level ',st_levels_input(closest_layer)
    719. 

  719.                   CALL wrf_debug ( 0 , message )
    720. 

  720.                   DO j = jts , MIN(jde-1,jte)
    721. 

  721.                      DO i = its , MIN(ide-1,ite)
    722. 

  722.                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    723. 

  723.                         tmn(i,j) = st_input(i,closest_layer+1,j)
    724. 

  724.                      END DO
    725. 

  725.                   END DO
    726. 

  726.                END IF
    727. 

  727.             END IF
    728. 

  728. 

  729. #if 0
    730. 

  730.             ! Loop over layers and do a weighted mean
    731. 

  731.             IF ( ALLOCATED ( depth ) ) DEALLOCATE ( depth )
    732. 

  732.             ALLOCATE ( depth(num_st_levels_input) )
    733. 

  733.             IF ( flag_soil_layers == 1 ) THEN
    734. 

  734.                DO k = num_st_levels_input, 2, -1
    735. 

  735.                   depth(k) = st_levels_input(k) - st_levels_input(k-1)
    736. 

  736.                END DO
    737. 

  737.                depth(1) = st_levels_input(1)
    738. 

  738.             ELSE IF ( flag_soil_levels == 1 ) THEN
    739. 

  739.                DO k = 2, num_st_levels_input
    740. 

  740.                   depth(k) = st_levels_input(k) - st_levels_input(k-1)
    741. 

  741.                END DO
    742. 

  742.                depth(1) = 0.
    743. 

  743.             END IF
    744. 

  744. 

  745.             DO j = jts , MIN(jde-1,jte)
    746. 

  746.                DO i = its , MIN(ide-1,ite)
    747. 

  747.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    748. 

  748.                   tmn(i,j) = 0.
    749. 

  749.                   DO k = 1, num_st_levels_input
    750. 

  750.                      tmn(i,j) = tmn(i,j) + depth(k) * st_input(i,k,j)
    751. 

  751.                   END DO
    752. 

  752.                END DO
    753. 

  753.             END DO
    754. 

  754.             DEALLOCATE ( depth )
    755. 

  755. 

  756. #endif
    757. 

  757. 

  758.       END SELECT fix_bottom_level_for_temp
    759. 

  759. 

  760.       !  Adjust the various soil temperature values depending on the difference in
    761. 

  761.       !  elevation between the current model's elevation and the incoming data's
    762. 

  762.       !  orography.
    763. 

  763. 

  764.       adjust_soil : SELECT CASE ( sf_surface_physics )
    765. 

  765. 

  766.          CASE ( SLABSCHEME , LSMSCHEME , NOAHMPSCHEME , RUCLSMSCHEME, PXLSMSCHEME, SSIBSCHEME )
    767. 

  767.             CALL adjust_soil_temp_new ( tmn , sf_surface_physics , tsk , ht ,            &
    768. 

  768.                                         toposoil , landmask , st_input, st_levels_input, &
    769. 

  769.                                         flag_soilhgt , flag_tavgsfc ,                    &
    770. 

  770.                                         flag_soil_layers , flag_soil_levels,             &
    771. 

  771.                                         num_st_levels_input, num_st_levels_alloc,        &
    772. 

  772.                                         ids , ide , jds , jde , kds , kde ,              &
    773. 

  773.                                         ims , ime , jms , jme , kms , kme ,              &
    774. 

  774.                                         its , ite , jts , jte , kts , kte )
    775. 

  775. 

  776.       END SELECT adjust_soil
    777. 

  777. 

  778.       !  Initialize the soil depth, and the soil temperature and moisture.
    779. 

  779.    
    780. 

  780.       IF      ( ( sf_surface_physics .EQ. SLABSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    781. 

  781.          CALL init_soil_depth_1 ( zs , dzs , num_soil_layers )
    782. 

  782.          CALL init_soil_1_real ( tsk , tmn , tslb , zs , dzs , num_soil_layers , real_data_init_type , &
    783. 

  783.                                  landmask , sst , flag_sst , &
    784. 

  784.                                  ids , ide , jds , jde , kds , kde , &
    785. 

  785.                                  ims , ime , jms , jme , kms , kme , &
    786. 

  786.                                  its , ite , jts , jte , kts , kte )
    787. 

  787. 

  788.       ELSE IF ( ( sf_surface_physics .EQ. LSMSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    789. 

  789.          CALL init_soil_depth_2 ( zs , dzs , num_soil_layers )
    790. 

  790.          CALL init_soil_2_real ( tsk , tmn , smois , sh2o , tslb , &
    791. 

  791.                                  st_input , sm_input , sw_input , landmask , sst , &
    792. 

  792.                                  zs , dzs , &
    793. 

  793.                                  st_levels_input , sm_levels_input , sw_levels_input , &
    794. 

  794.                                  num_soil_layers , num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
    795. 

  795.                                  num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , &
    796. 

  796.                                  flag_sst , flag_soil_layers , flag_soil_levels , &
    797. 

  797.                                  ids , ide , jds , jde , kds , kde , &
    798. 

  798.                                  ims , ime , jms , jme , kms , kme , &
    799. 

  799.                                  its , ite , jts , jte , kts , kte )
    800. 

  800.       ELSE IF ( ( sf_surface_physics .EQ. NOAHMPSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    801. 

  801.          CALL init_soil_depth_2 ( zs , dzs , num_soil_layers )
    802. 

  802.          CALL init_soil_2_real ( tsk , tmn , smois , sh2o , tslb , &
    803. 

  803.                                  st_input , sm_input , sw_input , landmask , sst , &
    804. 

  804.                                  zs , dzs , &
    805. 

  805.                                  st_levels_input , sm_levels_input , sw_levels_input , &
    806. 

  806.                                  num_soil_layers , num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
    807. 

  807.                                  num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , &
    808. 

  808.                                  flag_sst , flag_soil_layers , flag_soil_levels , &
    809. 

  809.                                  ids , ide , jds , jde , kds , kde , &
    810. 

  810.                                  ims , ime , jms , jme , kms , kme , &
    811. 

  811.                                  its , ite , jts , jte , kts , kte )
    812. 

  812.       ELSE IF ( ( sf_surface_physics .EQ. RUCLSMSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    813. 

  813.          CALL init_soil_depth_3 ( zs , dzs , num_soil_layers )
    814. 

  814.          CALL init_soil_3_real ( tsk , tmn , smois , tslb , &
    815. 

  815.                                  st_input , sm_input , landmask , sst , &
    816. 

  816.                                  zs , dzs , &
    817. 

  817.                                  st_levels_input , sm_levels_input , &
    818. 

  818.                                  num_soil_layers , num_st_levels_input , num_sm_levels_input , &
    819. 

  819.                                  num_st_levels_alloc , num_sm_levels_alloc , &
    820. 

  820.                                  flag_sst , flag_soil_layers , flag_soil_levels , &
    821. 

  821.                                  ids , ide , jds , jde , kds , kde , &
    822. 

  822.                                  ims , ime , jms , jme , kms , kme , &
    823. 

  823.                                  its , ite , jts , jte , kts , kte )
    824. 

  824.       ELSE IF ( ( sf_surface_physics .EQ. PXLSMSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    825. 

  825.          CALL init_soil_depth_7 ( zs , dzs , num_soil_layers )
    826. 

  826.          CALL init_soil_7_real ( tsk , tmn , smois , sh2o, tslb , &
    827. 

  827.                                  st_input , sm_input , sw_input, landmask , sst , &
    828. 

  828.                                  zs , dzs , &
    829. 

  829.                                  st_levels_input , sm_levels_input , sw_levels_input, &
    830. 

  830.                                  num_soil_layers , num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
    831. 

  831.                                  num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , &
    832. 

  832.                                  flag_sst , flag_soil_layers , flag_soil_levels , &
    833. 

  833.                                  ids , ide , jds , jde , kds , kde , &
    834. 

  834.                                  ims , ime , jms , jme , kms , kme , &
    835. 

  835.                                  its , ite , jts , jte , kts , kte )
    836. 

  836.       ELSE IF ( ( sf_surface_physics .EQ. 8 ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    837. 

  837.          CALL init_soil_depth_8 ( zs , dzs , num_soil_layers )
    838. 

  838.          CALL init_soil_3_real ( tsk , tmn , smois , tslb , &
    839. 

  839.                                  st_input , sm_input , landmask , sst , &
    840. 

  840.                                  zs , dzs , &
    841. 

  841.                                  st_levels_input , sm_levels_input , &
    842. 

  842.                                  num_soil_layers , num_st_levels_input , num_sm_levels_input , &
    843. 

  843.                                  num_st_levels_alloc , num_sm_levels_alloc , &
    844. 

  844.                                  flag_sst , flag_soil_layers , flag_soil_levels , &
    845. 

  845.                                  ids , ide , jds , jde , kds , kde , &
    846. 

  846.                                  ims , ime , jms , jme , kms , kme , &
    847. 

  847.                                  its , ite , jts , jte , kts , kte )
    848. 

  848.       END IF
    849. 

  849. 

  850.    END SUBROUTINE process_soil_real
    851. 

  851. 

  852.    SUBROUTINE process_soil_ideal ( xland,xice,vegfra,snow,canwat,  &
    853. 

  853.                                    ivgtyp,isltyp,tslb,smois, &
    854. 

  854.                                    tsk,tmn,zs,dzs,           &
    855. 

  855.                                    num_soil_layers,          &
    856. 

  856.                                    sf_surface_physics ,      &
    857. 

  857.                                    ids,ide, jds,jde, kds,kde,&
    858. 

  858.                                    ims,ime, jms,jme, kms,kme,&
    859. 

  859.                                    its,ite, jts,jte, kts,kte )
    860. 

  860. 

  861.       IMPLICIT NONE
    862. 

  862. 

  863.       INTEGER, INTENT(IN) ::ids,ide, jds,jde, kds,kde,  &
    864. 

  864.                             ims,ime, jms,jme, kms,kme,  &
    865. 

  865.                             its,ite, jts,jte, kts,kte
    866. 

  866. 

  867.       INTEGER, INTENT(IN) :: num_soil_layers , sf_surface_physics
    868. 

  868. 

  869.       REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , INTENT(INOUT) :: smois, tslb
    870. 

  870. 

  871.       REAL, DIMENSION(num_soil_layers), INTENT(OUT) :: dzs,zs
    872. 

  872. 

  873.       REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT) :: tsk, tmn
    874. 

  874.       REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: xland, snow, canwat, xice, vegfra
    875. 

  875.       INTEGER, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: ivgtyp, isltyp
    876. 

  876. 

  877.       !  Local variables.
    878. 

  878. 

  879.       INTEGER :: itf,jtf
    880. 

  880. 

  881.       itf=MIN(ite,ide-1)
    882. 

  882.       jtf=MIN(jte,jde-1)
    883. 

  883. 

  884.       IF      ( ( sf_surface_physics .EQ. SLABSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    885. 

  885.          CALL init_soil_depth_1 ( zs , dzs , num_soil_layers )
    886. 

  886.          CALL init_soil_1_ideal(tsk,tmn,tslb,xland,                      &
    887. 

  887.                                 ivgtyp,zs,dzs,num_soil_layers,           &
    888. 

  888.                                 ids,ide, jds,jde, kds,kde,               &
    889. 

  889.                                 ims,ime, jms,jme, kms,kme,               &
    890. 

  890.                                 its,ite, jts,jte, kts,kte                )
    891. 

  891.       ELSE IF ( ( sf_surface_physics .EQ. LSMSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    892. 

  892.          CALL init_soil_depth_2 ( zs , dzs , num_soil_layers )
    893. 

  893.          CALL init_soil_2_ideal ( xland,xice,vegfra,snow,canwat,         &
    894. 

  894.                                   ivgtyp,isltyp,tslb,smois,tmn,          &
    895. 

  895.                                   num_soil_layers,                       &
    896. 

  896.                                   ids,ide, jds,jde, kds,kde,             &
    897. 

  897.                                   ims,ime, jms,jme, kms,kme,             &
    898. 

  898.                                   its,ite, jts,jte, kts,kte              )
    899. 

  899.       ELSE IF ( ( sf_surface_physics .EQ. NOAHMPSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    900. 

  900.          CALL init_soil_depth_2 ( zs , dzs , num_soil_layers )
    901. 

  901.          CALL init_soil_2_ideal ( xland,xice,vegfra,snow,canwat,         &
    902. 

  902.                                   ivgtyp,isltyp,tslb,smois,tmn,          &
    903. 

  903.                                   num_soil_layers,                       &
    904. 

  904.                                   ids,ide, jds,jde, kds,kde,             &
    905. 

  905.                                   ims,ime, jms,jme, kms,kme,             &
    906. 

  906.                                   its,ite, jts,jte, kts,kte              )
    907. 

  907.       ELSE IF ( ( sf_surface_physics .EQ. RUCLSMSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    908. 

  908.          CALL init_soil_depth_3 ( zs , dzs , num_soil_layers )
    909. 

  909. 

  910.       END IF
    911. 

  911. 

  912.    END SUBROUTINE process_soil_ideal
    913. 

  913. 

  914.    SUBROUTINE adjust_soil_temp_new ( tmn , sf_surface_physics , tsk , ter ,            &
    915. 

  915.                                      toposoil , landmask , st_input , st_levels_input, &
    916. 

  916.                                      flag_toposoil , flag_tavgsfc ,                    &
    917. 

  917.                                      flag_soil_layers , flag_soil_levels,              &
    918. 

  918.                                      num_st_levels_input, num_st_levels_alloc,         &
    919. 

  919.                                      ids , ide , jds , jde , kds , kde ,               &
    920. 

  920.                                      ims , ime , jms , jme , kms , kme ,               &
    921. 

  921.                                      its , ite , jts , jte , kts , kte )
    922. 

  922. 

  923.       IMPLICIT NONE
    924. 

  924. 

  925.       INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
    926. 

  926.                               ims , ime , jms , jme , kms , kme , &
    927. 

  927.                               its , ite , jts , jte , kts , kte 
    928. 

  928.       INTEGER , INTENT(IN) :: num_st_levels_input, num_st_levels_alloc
    929. 

  929. 

  930.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN)    :: ter , toposoil , landmask
    931. 

  931.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tmn , tsk
    932. 

  932.       REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input
    933. 

  933.       INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(IN) :: st_levels_input
    934. 

  934. 

  935.       INTEGER , INTENT(IN) :: sf_surface_physics , flag_toposoil , flag_tavgsfc
    936. 

  936.       INTEGER , INTENT(IN) :: flag_soil_layers , flag_soil_levels
    937. 

  937.  
    938. 

  938.       INTEGER :: i , j, k , st_near_sfc
    939. 

  939. 

  940.       REAL :: soil_elev_min_val ,  soil_elev_max_val , soil_elev_min_dif , soil_elev_max_dif
    941. 

  941. 

  942.       !  Adjust the annual mean temperature as if it is based on from a sea-level elevation
    943. 

  943.       !  if the value used is from the actual annula mean data set.  If the input field to
    944. 

  944.       !  be used for tmn is one of the first-guess input temp fields, need to do an adjustment
    945. 

  945.       !  only on the diff in topo from the model terrain and the first-guess terrain.
    946. 

  946. 

  947.        SELECT CASE ( sf_surface_physics )
    948. 

  948. 

  949.          CASE ( LSMSCHEME , NOAHMPSCHEME )
    950. 

  950.             DO j = jts , MIN(jde-1,jte)
    951. 

  951.                DO i = its , MIN(ide-1,ite)
    952. 

  952.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    953. 

  953.                   IF (landmask(i,j) .GT. 0.5 ) THEN
    954. 

  954.                      tmn(i,j) = tmn(i,j) - 0.0065 * ter(i,j)
    955. 

  955.                   END IF
    956. 

  956.                END DO
    957. 

  957.             END DO
    958. 

  958. 

  959.          CASE (RUCLSMSCHEME)
    960. 

  960.             DO j = jts , MIN(jde-1,jte)
    961. 

  961.                DO i = its , MIN(ide-1,ite)
    962. 

  962.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    963. 

  963.                   IF (landmask(i,j) .GT. 0.5 ) THEN
    964. 

  964.                      tmn(i,j) = tmn(i,j) - 0.0065 * ter(i,j)
    965. 

  965.                   END IF
    966. 

  966.                END DO
    967. 

  967.             END DO
    968. 

  968. 

  969.       END SELECT
    970. 

  970. 

  971. 

  972.       !  Do we have a soil field with which to modify soil temperatures?
    973. 

  973. 

  974.       IF ( flag_toposoil .EQ. 1 ) THEN
    975. 

  975. 

  976.          DO j = jts , MIN(jde-1,jte)
    977. 

  977.             DO i = its , MIN(ide-1,ite)
    978. 

  978. 

  979.                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    980. 

  980.                !  Is the toposoil field OK, or is it a subversive soil elevation field.  We can tell
    981. 

  981.                !  usually by looking at values.  Anything less than -1000 m (lower than the Dead Sea) is
    982. 

  982.                !  bad.  Anything larger than 10 km (taller than Everest) is toast.  Also, anything where
    983. 

  983.                !  the difference between the soil elevation and the terrain is greater than 3 km means
    984. 

  984.                !  that the soil data is either all zeros or that the data are inconsistent.  Any of these
    985. 

  985.                !  three conditions is grievous enough to induce a WRF fatality.  However, if they are at
    986. 

  986.                !  a water point, then we can safely ignore them.
    987. 

  987. 

  988.                soil_elev_min_val = toposoil(i,j)
    989. 

  989.                soil_elev_max_val = toposoil(i,j)
    990. 

  990.                soil_elev_min_dif = ter(i,j) - toposoil(i,j)
    991. 

  991.                soil_elev_max_dif = ter(i,j) - toposoil(i,j)
    992. 

  992. 

  993.                IF      ( ( soil_elev_min_val .LT. -1000 ) .AND. ( landmask(i,j) .LT. 0.5 ) ) THEN
    994. 

  994.                   CYCLE
    995. 

  995.                ELSE IF ( ( soil_elev_min_val .LT. -1000 ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
    996. 

  996. !print *,'no soil temperature elevation adjustment, soil height too small = ',toposoil(i,j)
    997. 

  997. cycle
    998. 

  998. !                 CALL wrf_error_fatal ( 'TOPOSOIL values have large negative values < -1000 m, unrealistic.' )
    999. 

  999.                ENDIF
    1000. 

  1000. 

  1001.                IF      ( ( soil_elev_max_val .GT. 10000 ) .AND. ( landmask(i,j) .LT. 0.5 ) ) THEN
    1002. 

  1002.                   CYCLE
    1003. 

  1003.                ELSE IF ( ( soil_elev_max_val .GT. 10000 ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
    1004. 

  1004. print *,'no soil temperature elevation adjustment, soil height too high = ',toposoil(i,j)
    1005. 

  1005. cycle
    1006. 

  1006.                   CALL wrf_error_fatal ( 'TOPOSOIL values have large positive values > 10,000 m , unrealistic.' )
    1007. 

  1007.                ENDIF
    1008. 

  1008. 

  1009.                IF      ( ( ( soil_elev_min_dif .LT. -3000 ) .OR. ( soil_elev_max_dif .GT. 3000 ) ) .AND. &
    1010. 

  1010.                            ( landmask(i,j) .LT. 0.5 ) ) THEN
    1011. 

  1011.                   CYCLE
    1012. 

  1012.                ELSE IF ( ( ( soil_elev_min_dif .LT. -3000 ) .OR. ( soil_elev_max_dif .GT. 3000 ) ) .AND. &
    1013. 

  1013.                            ( landmask(i,j) .GT. 0.5 ) ) THEN
    1014. 

  1014. print *,'no soil temperature elevation adjustment, diff of soil height and terrain = ',ter(i,j) - toposoil(i,j)
    1015. 

  1015. cycle
    1016. 

  1016.                   CALL wrf_error_fatal ( 'TOPOSOIL difference with terrain elevation differs by more than 3000 m, unrealistic' )
    1017. 

  1017.                ENDIF
    1018. 

  1018. 

  1019.                !  For each of the fields that we would like to modify, check to see if it came in from the SI.
    1020. 

  1020.                !  If so, then use a -6.5 K/km lapse rate (based on the elevation diffs).  We only adjust when we
    1021. 

  1021.                !  are not at a water point.
    1022. 

  1022. 

  1023.                IF (landmask(i,j) .GT. 0.5 ) THEN
    1024. 

  1024.                   IF ( sf_surface_physics .EQ. SLABSCHEME ) THEN
    1025. 

  1025.                      st_near_sfc = 0                             ! Check if there is a soil layer above 40 cm
    1026. 

  1026.                      DO k = 1, num_st_levels_input
    1027. 

  1027.                         IF ( st_levels_input(k) .LE. 40 ) THEN
    1028. 

  1028.                            st_near_sfc = 1
    1029. 

  1029.                         END IF
    1030. 

  1030.                      END DO
    1031. 

  1031.                      IF ( ( flag_tavgsfc  == 1 ) .OR. ( st_near_sfc == 1 ) ) THEN
    1032. 

  1032.                         tmn(i,j) = tmn(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    1033. 

  1033.                      ELSE
    1034. 

  1034.                         tmn(i,j) = tmn(i,j) - 0.0065 * ter(i,j)
    1035. 

  1035.                      END IF
    1036. 

  1036.                   END IF
    1037. 

  1037. 

  1038.                   tsk(i,j) = tsk(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    1039. 

  1039.       
    1040. 

  1040.                   IF ( flag_soil_layers == 1 ) THEN
    1041. 

  1041.                      DO k = 2, num_st_levels_input+1
    1042. 

  1042.                         st_input(i,k,j) = st_input(i,k,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    1043. 

  1043.                      END DO
    1044. 

  1044.                   ELSE
    1045. 

  1045.                      DO k = 1, num_st_levels_input
    1046. 

  1046.                         st_input(i,k,j) = st_input(i,k,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    1047. 

  1047.                      END DO
    1048. 

  1048.                   END IF
    1049. 

  1049. 

  1050.                END IF
    1051. 

  1051.             END DO
    1052. 

  1052.          END DO
    1053. 

  1053. 

  1054.       END IF
    1055. 

  1055. 

  1056.    END SUBROUTINE adjust_soil_temp_new
    1057. 

  1057. 

  1058. 

  1059.    SUBROUTINE init_soil_depth_1 ( zs , dzs , num_soil_layers )
    1060. 

  1060. 

  1061.       IMPLICIT NONE
    1062. 

  1062. 

  1063.       INTEGER, INTENT(IN) :: num_soil_layers
    1064. 

  1064. 

  1065.       REAL, DIMENSION(1:num_soil_layers), INTENT(OUT)  ::  zs,dzs
    1066. 

  1066. 

  1067.       INTEGER                   ::      l
    1068. 

  1068. 

  1069.       !  Define layers (top layer = 0.01 m).  Double the thicknesses at each step (dzs values).
    1070. 

  1070.       !  The distance from the ground level to the midpoint of the layer is given by zs.
    1071. 

  1071. 

  1072.       !    -------   Ground Level   ----------      ||      ||   ||  ||
    1073. 

  1073.       !                                             ||      ||   ||  || zs(1) = 0.005 m
    1074. 

  1074.       !    --  --  --  --  --  --  --  --  --       ||      ||   ||  \/
    1075. 

  1075.       !                                             ||      ||   ||
    1076. 

  1076.       !    -----------------------------------      ||  ||  ||   \/   dzs(1) = 0.01 m
    1077. 

  1077.       !                                             ||  ||  ||
    1078. 

  1078.       !                                             ||  ||  || zs(2) = 0.02
    1079. 

  1079.       !    --  --  --  --  --  --  --  --  --       ||  ||  \/
    1080. 

  1080.       !                                             ||  ||
    1081. 

  1081.       !                                             ||  ||
    1082. 

  1082.       !    -----------------------------------  ||  ||  \/   dzs(2) = 0.02 m
    1083. 

  1083.       !                                         ||  ||
    1084. 

  1084.       !                                         ||  ||
    1085. 

  1085.       !                                         ||  ||
    1086. 

  1086.       !                                         ||  || zs(3) = 0.05
    1087. 

  1087.       !    --  --  --  --  --  --  --  --  --   ||  \/
    1088. 

  1088.       !                                         ||
    1089. 

  1089.       !                                         ||
    1090. 

  1090.       !                                         ||
    1091. 

  1091.       !                                         ||
    1092. 

  1092.       !    -----------------------------------  \/   dzs(3) = 0.04 m
    1093. 

  1093. 

  1094.       IF ( num_soil_layers .NE. 5 ) THEN
    1095. 

  1095.          PRINT '(A)','Usually, the 5-layer diffusion uses 5 layers.  Change this in the namelist.'
    1096. 

  1096.          CALL wrf_error_fatal ( '5-layer_diffusion_uses_5_layers' )
    1097. 

  1097.       END IF
    1098. 

  1098. 

  1099.       dzs(1)=.01
    1100. 

  1100.       zs(1)=.5*dzs(1)
    1101. 

  1101. 

  1102.       DO l=2,num_soil_layers
    1103. 

  1103.          dzs(l)=2*dzs(l-1)
    1104. 

  1104.          zs(l)=zs(l-1)+.5*dzs(l-1)+.5*dzs(l)
    1105. 

  1105.       ENDDO
    1106. 

  1106. 

  1107.    END SUBROUTINE init_soil_depth_1
    1108. 

  1108. 

  1109.    SUBROUTINE init_soil_depth_2 ( zs , dzs , num_soil_layers )
    1110. 

  1110. 

  1111.       IMPLICIT NONE
    1112. 

  1112. 

  1113.       INTEGER, INTENT(IN) :: num_soil_layers
    1114. 

  1114. 

  1115.       REAL, DIMENSION(1:num_soil_layers), INTENT(OUT)  ::  zs,dzs
    1116. 

  1116. 

  1117.       INTEGER                   ::      l
    1118. 

  1118. 

  1119.       dzs = (/ 0.1 , 0.3 , 0.6 , 1.0 /)
    1120. 

  1120. 

  1121.       IF ( num_soil_layers .NE. 4 ) THEN
    1122. 

  1122.          PRINT '(A)','Usually, the LSM uses 4 layers.  Change this in the namelist.'
    1123. 

  1123.          CALL wrf_error_fatal ( 'LSM_uses_4_layers' )
    1124. 

  1124.       END IF
    1125. 

  1125. 

  1126.       zs(1)=.5*dzs(1)
    1127. 

  1127. 

  1128.       DO l=2,num_soil_layers
    1129. 

  1129.          zs(l)=zs(l-1)+.5*dzs(l-1)+.5*dzs(l)
    1130. 

  1130.       ENDDO
    1131. 

  1131. 

  1132.    END SUBROUTINE init_soil_depth_2
    1133. 

  1133. 

  1134.    SUBROUTINE init_soil_depth_3 ( zs , dzs , num_soil_layers )
    1135. 

  1135. 

  1136.       IMPLICIT NONE
    1137. 

  1137. 

  1138.       INTEGER, INTENT(IN) :: num_soil_layers
    1139. 

  1139. 

  1140.       REAL, DIMENSION(1:num_soil_layers), INTENT(OUT)  ::  zs,dzs
    1141. 

  1141. 

  1142.       INTEGER                   ::      l
    1143. 

  1143. 

  1144.       CHARACTER (LEN=132) :: message
    1145. 

  1145. 

  1146. ! in RUC LSM ZS - soil levels, and DZS - soil layer thicknesses, not used
    1147. 

  1147. ! ZS is specified in the namelist: num_soil_layers = 6 or 9.
    1148. 

  1148. ! Other options with number of levels are possible, but
    1149. 

  1149. ! WRF users should change consistently the namelist entry with the
    1150. 

  1150. !    ZS array in this subroutine.
    1151. 

  1151. 

  1152.      IF ( num_soil_layers .EQ. 6) THEN
    1153. 

  1153.       zs  = (/ 0.00 , 0.05 , 0.20 , 0.40 , 1.60 , 3.00 /)
    1154. 

  1154. !      dzs = (/ 0.00 , 0.125, 0.175 , 0.70 , 1.30 , 1.40 /)
    1155. 

  1155.      ELSEIF ( num_soil_layers .EQ. 9) THEN
    1156. 

  1156.       zs  = (/ 0.00 , 0.05 , 0.20 , 0.40 , 0.60, 1.00, 1.60 , 2.20, 3.00 /)
    1157. 

  1157. !      dzs = (/ 0.00 , 0.125, 0.175 , 0.70 , 1.30 , 1.40 /)
    1158. 

  1158.      ENDIF
    1159. 

  1159. 

  1160.       IF ( num_soil_layers .EQ. 4 .OR. num_soil_layers .EQ. 5 ) THEN
    1161. 

  1161.          write (message, FMT='(A)') 'The RUC LSM uses 6, 9 or more levels.  Change this in the namelist.'
    1162. 

  1162.          CALL wrf_error_fatal ( message )
    1163. 

  1163.       END IF
    1164. 

  1164. 

  1165.    END SUBROUTINE init_soil_depth_3
    1166. 

  1166. 

  1167.    SUBROUTINE init_soil_depth_7 ( zs , dzs , num_soil_layers )
    1168. 

  1168. 

  1169.       IMPLICIT NONE
    1170. 

  1170. 

  1171.       INTEGER, INTENT(IN) :: num_soil_layers
    1172. 

  1172. 

  1173.       REAL, DIMENSION(1:num_soil_layers), INTENT(OUT)  ::  zs,dzs
    1174. 

  1174. 

  1175.       INTEGER                   ::      l
    1176. 

  1176. 

  1177.       dzs = (/ 0.01 , 0.99 /)
    1178. 

  1178. 

  1179.       IF ( num_soil_layers .NE. 2 ) THEN
    1180. 

  1180.          PRINT '(A)','Usually, the PX LSM uses 2 layers.  Change this in the namelist.'
    1181. 

  1181.          CALL wrf_error_fatal ( 'PXLSM_uses_2_layers' )
    1182. 

  1182.       END IF
    1183. 

  1183. 

  1184.       zs(1) = 0.5 * dzs(1)
    1185. 

  1185.       zs(2) = dzs(1) + 0.5 * dzs(2)
    1186. 

  1186. 

  1187.    END SUBROUTINE init_soil_depth_7
    1188. 

  1188. 

  1189.    SUBROUTINE init_soil_depth_8 ( zs , dzs , num_soil_layers )
    1190. 

  1190. 

  1191.       IMPLICIT NONE
    1192. 

  1192. 

  1193.       INTEGER, INTENT(IN) :: num_soil_layers
    1194. 

  1194. 

  1195.       REAL, DIMENSION(1:num_soil_layers), INTENT(OUT)  ::  zs,dzs
    1196. 

  1196. 

  1197.       INTEGER                   ::      l
    1198. 

  1198. 

  1199.       zs(1) = 0.00
    1200. 

  1200.       zs(2) = 0.05
    1201. 

  1201.       zs(3) = 1.05
    1202. 

  1202. 

  1203.    END SUBROUTINE init_soil_depth_8
    1204. 

  1204. 

  1205.    SUBROUTINE init_soil_1_real ( tsk , tmn , tslb , zs , dzs , &
    1206. 

  1206.                                  num_soil_layers , real_data_init_type , &
    1207. 

  1207.                                  landmask , sst , flag_sst , &
    1208. 

  1208.                                  ids , ide , jds , jde , kds , kde , &
    1209. 

  1209.                                  ims , ime , jms , jme , kms , kme , &
    1210. 

  1210.                                  its , ite , jts , jte , kts , kte )
    1211. 

  1211. 

  1212.       IMPLICIT NONE
    1213. 

  1213. 

  1214.       INTEGER , INTENT(IN) :: num_soil_layers , real_data_init_type , &
    1215. 

  1215.                               ids , ide , jds , jde , kds , kde , &
    1216. 

  1216.                               ims , ime , jms , jme , kms , kme , &
    1217. 

  1217.                               its , ite , jts , jte , kts , kte
    1218. 

  1218. 

  1219.       INTEGER , INTENT(IN) :: flag_sst
    1220. 

  1220. 

  1221.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst
    1222. 

  1222.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tsk , tmn
    1223. 

  1223. 

  1224.       REAL , DIMENSION(num_soil_layers) :: zs , dzs
    1225. 

  1225. 

  1226.       REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb
    1227. 

  1227. 

  1228.       INTEGER :: i , j , l
    1229. 

  1229. 

  1230.       !  Soil temperature is linearly interpolated between the skin temperature (taken to be at a
    1231. 

  1231.       !  depth of 0.5 cm) and the deep soil, annual temperature (taken to be at a depth of 23 cm).
    1232. 

  1232.       !  The tslb(i,1,j) is the skin temperature, and the tslb(i,num_soil_layers,j) level is the
    1233. 

  1233.       !  annual mean temperature.
    1234. 

  1234. 

  1235.       DO j = jts , MIN(jde-1,jte)
    1236. 

  1236.          DO i = its , MIN(ide-1,ite)
    1237. 

  1237.             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1238. 

  1238.             IF ( landmask(i,j) .GT. 0.5 ) THEN
    1239. 

  1239.                DO l = 1 , num_soil_layers
    1240. 

  1240.                   tslb(i,l,j)= ( tsk(i,j) * ( zs(num_soil_layers) - zs(l) )   + &
    1241. 

  1241.                                  tmn(i,j) * ( zs(              l) - zs(1) ) ) / &
    1242. 

  1242.                                             ( zs(num_soil_layers) - zs(1) )
    1243. 

  1243.                END DO
    1244. 

  1244.             ELSE
    1245. 

  1245.                IF ( ( real_data_init_type .EQ. 1 ) .AND. ( flag_sst .EQ. 1 ) ) THEN
    1246. 

  1246.                   DO l = 1 , num_soil_layers
    1247. 

  1247.                      tslb(i,l,j)= sst(i,j)
    1248. 

  1248.                   END DO
    1249. 

  1249.                ELSE
    1250. 

  1250.                   DO l = 1 , num_soil_layers
    1251. 

  1251.                      tslb(i,l,j)= tsk(i,j)
    1252. 

  1252.                   END DO
    1253. 

  1253.                END IF
    1254. 

  1254.             END IF
    1255. 

  1255.          END DO
    1256. 

  1256.       END DO
    1257. 

  1257. 

  1258.    END SUBROUTINE init_soil_1_real
    1259. 

  1259. 

  1260.    SUBROUTINE init_soil_1_ideal(tsk,tmn,tslb,xland,             &
    1261. 

  1261.                        ivgtyp,ZS,DZS,num_soil_layers,           &
    1262. 

  1262.                        ids,ide, jds,jde, kds,kde,               &
    1263. 

  1263.                        ims,ime, jms,jme, kms,kme,               &
    1264. 

  1264.                        its,ite, jts,jte, kts,kte                )
    1265. 

  1265. 

  1266.       IMPLICIT NONE
    1267. 

  1267. 

  1268.       INTEGER, INTENT(IN   )    ::      ids,ide, jds,jde, kds,kde, &
    1269. 

  1269.                                         ims,ime, jms,jme, kms,kme, &
    1270. 

  1270.                                         its,ite, jts,jte, kts,kte
    1271. 

  1271. 

  1272.       INTEGER, INTENT(IN   )    ::      num_soil_layers
    1273. 

  1273. 

  1274.       REAL, DIMENSION( ims:ime , num_soil_layers , jms:jme ), INTENT(OUT) :: tslb
    1275. 

  1275.       REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: xland
    1276. 

  1276.       INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: ivgtyp
    1277. 

  1277. 

  1278.       REAL, DIMENSION(1:), INTENT(IN) :: dzs,zs
    1279. 

  1279. 

  1280.       REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(IN) :: tsk, tmn
    1281. 

  1281. 

  1282.       !  Lcal variables.
    1283. 

  1283. 

  1284.       INTEGER :: l,j,i,itf,jtf
    1285. 

  1285. 

  1286.       itf=MIN(ite,ide-1)
    1287. 

  1287.       jtf=MIN(jte,jde-1)
    1288. 

  1288. 

  1289.       IF (num_soil_layers.NE.1)THEN
    1290. 

  1290.          DO j=jts,jtf
    1291. 

  1291.             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1292. 

  1292.             DO l=1,num_soil_layers
    1293. 

  1293.                DO i=its,itf
    1294. 

  1294.                  tslb(i,l,j)=( tsk(i,j)*(zs(num_soil_layers)-zs(l)) + tmn(i,j)*(zs(l)-zs(1)) ) / &
    1295. 

  1295.                              ( zs(num_soil_layers)-zs(1) )
    1296. 

  1296.                ENDDO
    1297. 

  1297.             ENDDO
    1298. 

  1298.          ENDDO
    1299. 

  1299.       ENDIF
    1300. 

  1300. 

  1301. !     DO j=jts,jtf
    1302. 

  1302. !        DO i=its,itf
    1303. 

  1303. !          xland(i,j)  = 2
    1304. 

  1304. !          ivgtyp(i,j) = 7
    1305. 

  1305. !        ENDDO
    1306. 

  1306. !     ENDDO
    1307. 

  1307. 

  1308.    END SUBROUTINE init_soil_1_ideal
    1309. 

  1309. 

  1310.    SUBROUTINE init_soil_2_real ( tsk , tmn , smois , sh2o , tslb , &
    1311. 

  1311.                                  st_input , sm_input , sw_input , landmask , sst , &
    1312. 

  1312.                                  zs , dzs , &
    1313. 

  1313.                                  st_levels_input , sm_levels_input , sw_levels_input , &
    1314. 

  1314.                                  num_soil_layers , num_st_levels_input , num_sm_levels_input ,  num_sw_levels_input , &
    1315. 

  1315.                                  num_st_levels_alloc , num_sm_levels_alloc ,  num_sw_levels_alloc , &
    1316. 

  1316.                                  flag_sst , flag_soil_layers , flag_soil_levels , &
    1317. 

  1317.                                  ids , ide , jds , jde , kds , kde , &
    1318. 

  1318.                                  ims , ime , jms , jme , kms , kme , &
    1319. 

  1319.                                  its , ite , jts , jte , kts , kte )
    1320. 

  1320. 

  1321.       IMPLICIT NONE
    1322. 

  1322. 

  1323.       INTEGER , INTENT(IN) :: num_soil_layers , &
    1324. 

  1324.                               num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
    1325. 

  1325.                               num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , &
    1326. 

  1326.                               ids , ide , jds , jde , kds , kde , &
    1327. 

  1327.                               ims , ime , jms , jme , kms , kme , &
    1328. 

  1328.                               its , ite , jts , jte , kts , kte
    1329. 

  1329. 

  1330.       INTEGER , INTENT(IN) :: flag_sst, flag_soil_layers, flag_soil_levels
    1331. 

  1331. 

  1332.       INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input
    1333. 

  1333.       INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input
    1334. 

  1334.       INTEGER , DIMENSION(1:num_sw_levels_input) , INTENT(INOUT) :: sw_levels_input
    1335. 

  1335. 

  1336.       REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input
    1337. 

  1337.       REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input
    1338. 

  1338.       REAL , DIMENSION(ims:ime,1:num_sw_levels_alloc,jms:jme) , INTENT(INOUT) :: sw_input
    1339. 

  1339.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst
    1340. 

  1340. 

  1341.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn
    1342. 

  1342.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk
    1343. 

  1343.       REAL , DIMENSION(num_soil_layers) :: zs , dzs
    1344. 

  1344. 

  1345.       REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois , sh2o
    1346. 

  1346. 

  1347.       REAL , ALLOCATABLE , DIMENSION(:) :: zhave
    1348. 

  1348. 

  1349.       INTEGER :: i , j , l , lout , lin , lwant , lhave , num
    1350. 

  1350.       REAL :: temp
    1351. 

  1351.       LOGICAL :: found_levels
    1352. 

  1352. 

  1353.       CHARACTER (LEN=132) :: message
    1354. 

  1354. 

  1355.       !  Are there any soil temp and moisture levels - ya know, they are mandatory.
    1356. 

  1356. 

  1357.       num = num_st_levels_input * num_sm_levels_input
    1358. 

  1358. 

  1359.       IF ( num .GE. 1 ) THEN
    1360. 

  1360. 

  1361.          !  Ordered levels that we have data for.
    1362. 

  1362. 

  1363. !tgs add option to initialize from RUCLSM
    1364. 

  1364.          IF ( flag_soil_levels == 1 ) THEN
    1365. 

  1365.            write(message, FMT='(A)') ' Assume RUC LSM 6-level input'
    1366. 

  1366.            CALL wrf_message ( message )
    1367. 

  1367.            ALLOCATE ( zhave( MAX(num_st_levels_input,num_sm_levels_input,num_sw_levels_input)  ) )
    1368. 

  1368.          ELSE
    1369. 

  1369.            write(message, FMT='(A)') ' Assume Noah LSM input'
    1370. 

  1370.            CALL wrf_message ( message )
    1371. 

  1371.          ALLOCATE ( zhave( MAX(num_st_levels_input,num_sm_levels_input,num_sw_levels_input) +2) )
    1372. 

  1372.          END IF
    1373. 

  1373. 

  1374. 

  1375.          !  Sort the levels for temperature.
    1376. 

  1376. 

  1377.          outert : DO lout = 1 , num_st_levels_input-1
    1378. 

  1378.             innert : DO lin = lout+1 , num_st_levels_input
    1379. 

  1379.                IF ( st_levels_input(lout) .GT. st_levels_input(lin) ) THEN
    1380. 

  1380.                   temp = st_levels_input(lout)
    1381. 

  1381.                   st_levels_input(lout) = st_levels_input(lin)
    1382. 

  1382.                   st_levels_input(lin) = NINT(temp)
    1383. 

  1383.                   DO j = jts , MIN(jde-1,jte)
    1384. 

  1384.                      DO i = its , MIN(ide-1,ite)
    1385. 

  1385.                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1386. 

  1386.                         temp = st_input(i,lout+1,j)
    1387. 

  1387.                         st_input(i,lout+1,j) = st_input(i,lin+1,j)
    1388. 

  1388.                         st_input(i,lin+1,j) = temp
    1389. 

  1389.                      END DO
    1390. 

  1390.                   END DO
    1391. 

  1391.                END IF
    1392. 

  1392.             END DO innert
    1393. 

  1393.          END DO outert
    1394. 

  1394. !tgs add IF
    1395. 

  1395.       IF ( flag_soil_layers == 1 ) THEN
    1396. 

  1396.          DO j = jts , MIN(jde-1,jte)
    1397. 

  1397.             DO i = its , MIN(ide-1,ite)
    1398. 

  1398.                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1399. 

  1399.                st_input(i,1,j) = tsk(i,j)
    1400. 

  1400.                st_input(i,num_st_levels_input+2,j) = tmn(i,j)
    1401. 

  1401.             END DO
    1402. 

  1402.          END DO
    1403. 

  1403.       ENDIF
    1404. 

  1404. 

  1405.          !  Sort the levels for moisture.
    1406. 

  1406. 

  1407.          outerm: DO lout = 1 , num_sm_levels_input-1
    1408. 

  1408.             innerm : DO lin = lout+1 , num_sm_levels_input
    1409. 

  1409.                IF ( sm_levels_input(lout) .GT. sm_levels_input(lin) ) THEN
    1410. 

  1410.                   temp = sm_levels_input(lout)
    1411. 

  1411.                   sm_levels_input(lout) = sm_levels_input(lin)
    1412. 

  1412.                   sm_levels_input(lin) = NINT(temp)
    1413. 

  1413.                   DO j = jts , MIN(jde-1,jte)
    1414. 

  1414.                      DO i = its , MIN(ide-1,ite)
    1415. 

  1415.                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1416. 

  1416.                         temp = sm_input(i,lout+1,j)
    1417. 

  1417.                         sm_input(i,lout+1,j) = sm_input(i,lin+1,j)
    1418. 

  1418.                         sm_input(i,lin+1,j) = temp
    1419. 

  1419.                      END DO
    1420. 

  1420.                   END DO
    1421. 

  1421.                END IF
    1422. 

  1422.             END DO innerm
    1423. 

  1423.          END DO outerm
    1424. 

  1424. !tgs add IF
    1425. 

  1425.       IF ( flag_soil_layers == 1 ) THEN
    1426. 

  1426.          DO j = jts , MIN(jde-1,jte)
    1427. 

  1427.             DO i = its , MIN(ide-1,ite)
    1428. 

  1428.                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1429. 

  1429.                sm_input(i,1,j) = sm_input(i,2,j)
    1430. 

  1430.                sm_input(i,num_sm_levels_input+2,j) = sm_input(i,num_sm_levels_input+1,j)
    1431. 

  1431.             END DO
    1432. 

  1432.          END DO
    1433. 

  1433.       ENDIF
    1434. 

  1434. 

  1435.          !  Sort the levels for liquid moisture.
    1436. 

  1436. 

  1437.          outerw: DO lout = 1 , num_sw_levels_input-1
    1438. 

  1438.             innerw : DO lin = lout+1 , num_sw_levels_input
    1439. 

  1439.                IF ( sw_levels_input(lout) .GT. sw_levels_input(lin) ) THEN
    1440. 

  1440.                   temp = sw_levels_input(lout)
    1441. 

  1441.                   sw_levels_input(lout) = sw_levels_input(lin)
    1442. 

  1442.                   sw_levels_input(lin) = NINT(temp)
    1443. 

  1443.                   DO j = jts , MIN(jde-1,jte)
    1444. 

  1444.                      DO i = its , MIN(ide-1,ite)
    1445. 

  1445.                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1446. 

  1446.                         temp = sw_input(i,lout+1,j)
    1447. 

  1447.                         sw_input(i,lout+1,j) = sw_input(i,lin+1,j)
    1448. 

  1448.                         sw_input(i,lin+1,j) = temp
    1449. 

  1449.                      END DO
    1450. 

  1450.                   END DO
    1451. 

  1451.                END IF
    1452. 

  1452.             END DO innerw
    1453. 

  1453.          END DO outerw
    1454. 

  1454.          IF ( num_sw_levels_input .GT. 1 ) THEN
    1455. 

  1455.             DO j = jts , MIN(jde-1,jte)
    1456. 

  1456.                DO i = its , MIN(ide-1,ite)
    1457. 

  1457.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1458. 

  1458.                   sw_input(i,1,j) = sw_input(i,2,j)
    1459. 

  1459.                   sw_input(i,num_sw_levels_input+2,j) = sw_input(i,num_sw_levels_input+1,j)
    1460. 

  1460.                END DO
    1461. 

  1461.             END DO
    1462. 

  1462.          END IF
    1463. 

  1463. 

  1464.          found_levels = .TRUE.
    1465. 

  1465. 

  1466.       ELSE IF ( ( num .LE. 0 ) .AND. (  start_date .NE. current_date ) ) THEN
    1467. 

  1467. 

  1468.          found_levels = .FALSE.
    1469. 

  1469. 

  1470.       ELSE
    1471. 

  1471.          CALL wrf_error_fatal ( &
    1472. 

  1472.          'No input soil level data (temperature, moisture or liquid, or all are missing). Required for LSM.' )
    1473. 

  1473.       END IF
    1474. 

  1474. 

  1475.       !  Is it OK to continue?
    1476. 

  1476. 

  1477.       IF ( found_levels ) THEN
    1478. 

  1478. 

  1479.          !tgs:  Here are the levels that we have from the input for temperature.
    1480. 

  1480. 

  1481.          IF ( flag_soil_levels == 1 ) THEN
    1482. 

  1482.             DO l = 1 , num_st_levels_input
    1483. 

  1483.                zhave(l) = st_levels_input(l) / 100.
    1484. 

  1484.             END DO
    1485. 

  1485. 

  1486.          !  Interpolate between the layers we have (zhave) and those that we want (zs).
    1487. 

  1487. 

  1488.          z_wantt : DO lwant = 1 , num_soil_layers
    1489. 

  1489.             z_havet : DO lhave = 1 , num_st_levels_input -1
    1490. 

  1490.                IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    1491. 

  1491.                     ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    1492. 

  1492.                   DO j = jts , MIN(jde-1,jte)
    1493. 

  1493.                      DO i = its , MIN(ide-1,ite)
    1494. 

  1494.                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1495. 

  1495.                         tslb(i,lwant,j)= ( st_input(i,lhave,j ) * ( zhave(lhave+1) - zs   (lwant) ) + &
    1496. 

  1496.                                            st_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    1497. 

  1497.                                                                    ( zhave(lhave+1) - zhave(lhave) )
    1498. 

  1498.                      END DO
    1499. 

  1499.                   END DO
    1500. 

  1500.                   EXIT z_havet
    1501. 

  1501.                END IF
    1502. 

  1502.             END DO z_havet
    1503. 

  1503.          END DO z_wantt
    1504. 

  1504. 

  1505.          ELSE
    1506. 

  1506. 

  1507.          !  Here are the levels that we have from the input for temperature.  The input levels plus
    1508. 

  1508.          !  two more: the skin temperature at 0 cm, and the annual mean temperature at 300 cm.
    1509. 

  1509. 

  1510.          zhave(1) = 0.
    1511. 

  1511.          DO l = 1 , num_st_levels_input
    1512. 

  1512.             zhave(l+1) = st_levels_input(l) / 100.
    1513. 

  1513.          END DO
    1514. 

  1514.          zhave(num_st_levels_input+2) = 300. / 100.
    1515. 

  1515. 

  1516.          !  Interpolate between the layers we have (zhave) and those that we want (zs).
    1517. 

  1517. 

  1518.          z_wantt_2: DO lwant = 1 , num_soil_layers
    1519. 

  1519.             z_havet_2 : DO lhave = 1 , num_st_levels_input +2 -1
    1520. 

  1520.                IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    1521. 

  1521.                     ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    1522. 

  1522.                   DO j = jts , MIN(jde-1,jte)
    1523. 

  1523.                      DO i = its , MIN(ide-1,ite)
    1524. 

  1524.                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1525. 

  1525.                         tslb(i,lwant,j)= ( st_input(i,lhave  ,j) * ( zhave(lhave+1) - zs   (lwant) ) + &
    1526. 

  1526.                                            st_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    1527. 

  1527.                                                                    ( zhave(lhave+1) - zhave(lhave) )
    1528. 

  1528.                      END DO
    1529. 

  1529.                   END DO
    1530. 

  1530.                   EXIT z_havet_2
    1531. 

  1531.                END IF
    1532. 

  1532.             END DO z_havet_2
    1533. 

  1533.          END DO z_wantt_2
    1534. 

  1534. 

  1535.       END IF
    1536. 

  1536. 

  1537. !tgs:
    1538. 

  1538.       IF ( flag_soil_levels == 1 ) THEN
    1539. 

  1539.          DO l = 1 , num_sm_levels_input
    1540. 

  1540.             zhave(l) = sm_levels_input(l) / 100.
    1541. 

  1541.          END DO
    1542. 

  1542. 

  1543.       !  Interpolate between the layers we have (zhave) and those that we want (zs).
    1544. 

  1544. 

  1545.       z_wantm : DO lwant = 1 , num_soil_layers
    1546. 

  1546.          z_havem : DO lhave = 1 , num_sm_levels_input -1
    1547. 

  1547.             IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    1548. 

  1548.                  ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    1549. 

  1549.                DO j = jts , MIN(jde-1,jte)
    1550. 

  1550.                   DO i = its , MIN(ide-1,ite)
    1551. 

  1551.                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1552. 

  1552.                      smois(i,lwant,j)= ( sm_input(i,lhave,j ) * ( zhave(lhave+1) - zs   (lwant) ) + &
    1553. 

  1553.                                          sm_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    1554. 

  1554.                                                                  ( zhave(lhave+1) - zhave(lhave) )
    1555. 

  1555.                   END DO
    1556. 

  1556.                END DO
    1557. 

  1557.                EXIT z_havem
    1558. 

  1558.             END IF
    1559. 

  1559.          END DO z_havem
    1560. 

  1560.       END DO z_wantm
    1561. 

  1561. 

  1562.       ELSE
    1563. 

  1563.          !  Here are the levels that we have from the input for moisture.  The input levels plus
    1564. 

  1564.          !  two more: a value at 0 cm and one at 300 cm.  The 0 cm value is taken to be identical
    1565. 

  1565.          !  to the most shallow layer's value.  Similarly, the 300 cm value is taken to be the same
    1566. 

  1566.          !  as the most deep layer's value.
    1567. 

    1568. 

  1568.          zhave(1) = 0.
    1569. 

  1569.          DO l = 1 , num_sm_levels_input
    1570. 

  1570.             zhave(l+1) = sm_levels_input(l) / 100.
    1571. 

  1571.          END DO
    1572. 

  1572.          zhave(num_sm_levels_input+2) = 300. / 100.
    1573. 

  1573. 

  1574.          !  Interpolate between the layers we have (zhave) and those that we want (zs).
    1575. 

  1575. 

  1576.          z_wantm_2 : DO lwant = 1 , num_soil_layers
    1577. 

  1577.             z_havem_2 : DO lhave = 1 , num_sm_levels_input +2 -1
    1578. 

  1578.                IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    1579. 

  1579.                     ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    1580. 

  1580.                   DO j = jts , MIN(jde-1,jte)
    1581. 

  1581.                      DO i = its , MIN(ide-1,ite)
    1582. 

  1582.                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1583. 

  1583.                         smois(i,lwant,j)= ( sm_input(i,lhave  ,j) * ( zhave(lhave+1) - zs   (lwant) ) + &
    1584. 

  1584.                                             sm_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    1585. 

  1585.                                                                     ( zhave(lhave+1) - zhave(lhave) )
    1586. 

  1586.                      END DO
    1587. 

  1587.                   END DO
    1588. 

  1588.                   EXIT z_havem_2
    1589. 

  1589.                END IF
    1590. 

  1590.             END DO z_havem_2
    1591. 

  1591.          END DO z_wantm_2
    1592. 

  1592.        ENDIF
    1593. 

  1593. 

  1594.          !  Any liquid soil moisture to worry about?
    1595. 

  1595. 

  1596.          IF ( num_sw_levels_input .GT. 1 ) THEN
    1597. 

  1597. 

  1598.             zhave(1) = 0.
    1599. 

  1599.             DO l = 1 , num_sw_levels_input
    1600. 

  1600.                zhave(l+1) = sw_levels_input(l) / 100.
    1601. 

  1601.             END DO
    1602. 

  1602.             zhave(num_sw_levels_input+2) = 300. / 100.
    1603. 

  1603. 

  1604.             !  Interpolate between the layers we have (zhave) and those that we want (zs).
    1605. 

  1605. 

  1606.             z_wantw : DO lwant = 1 , num_soil_layers
    1607. 

  1607.                z_havew : DO lhave = 1 , num_sw_levels_input +2 -1
    1608. 

  1608.                   IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    1609. 

  1609.                        ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    1610. 

  1610.                      DO j = jts , MIN(jde-1,jte)
    1611. 

  1611.                         DO i = its , MIN(ide-1,ite)
    1612. 

  1612.                            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1613. 

  1613.                            sh2o(i,lwant,j)= ( sw_input(i,lhave  ,j) * ( zhave(lhave+1) - zs   (lwant) ) + &
    1614. 

  1614.                                                sw_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    1615. 

  1615.                                                                        ( zhave(lhave+1) - zhave(lhave) )
    1616. 

  1616.                         END DO
    1617. 

  1617.                      END DO
    1618. 

  1618.                      EXIT z_havew
    1619. 

  1619.                   END IF
    1620. 

  1620.                END DO z_havew
    1621. 

  1621.             END DO z_wantw
    1622. 

  1622. 

  1623.          END IF
    1624. 

  1624. 

  1625. 

  1626.          !  Over water, put in reasonable values for soil temperature and moisture.  These won't be
    1627. 

  1627.          !  used, but they will make a more continuous plot.
    1628. 

  1628. 

  1629.          IF ( flag_sst .EQ. 1 ) THEN
    1630. 

  1630.             DO j = jts , MIN(jde-1,jte)
    1631. 

  1631.                DO i = its , MIN(ide-1,ite)
    1632. 

  1632.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1633. 

  1633.                   IF ( landmask(i,j) .LT. 0.5 ) THEN
    1634. 

  1634.                      DO l = 1 , num_soil_layers
    1635. 

  1635.                         tslb(i,l,j)= sst(i,j)
    1636. 

  1636.                         smois(i,l,j)= 1.0
    1637. 

  1637.                         sh2o (i,l,j)= 1.0
    1638. 

  1638.                      END DO
    1639. 

  1639.                   END IF
    1640. 

  1640.                END DO
    1641. 

  1641.             END DO
    1642. 

  1642.          ELSE
    1643. 

  1643.             DO j = jts , MIN(jde-1,jte)
    1644. 

  1644.                DO i = its , MIN(ide-1,ite)
    1645. 

  1645.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1646. 

  1646.                   IF ( landmask(i,j) .LT. 0.5 ) THEN
    1647. 

  1647.                      DO l = 1 , num_soil_layers
    1648. 

  1648.                         tslb(i,l,j)= tsk(i,j)
    1649. 

  1649.                         smois(i,l,j)= 1.0
    1650. 

  1650.                         sh2o (i,l,j)= 1.0
    1651. 

  1651.                      END DO
    1652. 

  1652.                   END IF
    1653. 

  1653.                END DO
    1654. 

  1654.             END DO
    1655. 

  1655.          END IF
    1656. 

  1656. 

  1657.          DEALLOCATE (zhave)
    1658. 

  1658. 

  1659.       END IF
    1660. 

  1660. 

  1661.    END SUBROUTINE init_soil_2_real
    1662. 

  1662. 

  1663.    SUBROUTINE init_soil_2_ideal ( xland,xice,vegfra,snow,canwat,     &
    1664. 

  1664.                      ivgtyp,isltyp,tslb,smois,tmn,                  &
    1665. 

  1665.                      num_soil_layers,                               &
    1666. 

  1666.                      ids,ide, jds,jde, kds,kde,                     &
    1667. 

  1667.                      ims,ime, jms,jme, kms,kme,                     &
    1668. 

  1668.                      its,ite, jts,jte, kts,kte                      )
    1669. 

  1669. 

  1670.       IMPLICIT NONE
    1671. 

  1671. 

  1672.       INTEGER, INTENT(IN) ::ids,ide, jds,jde, kds,kde,  &
    1673. 

  1673.                             ims,ime, jms,jme, kms,kme,  &
    1674. 

  1674.                             its,ite, jts,jte, kts,kte
    1675. 

  1675. 

  1676.       INTEGER, INTENT(IN) ::num_soil_layers
    1677. 

  1677. 

  1678.       REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , INTENT(OUT) :: smois, tslb
    1679. 

  1679. 

  1680.       REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(IN)   :: xland
    1681. 

  1681.       REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT)  :: snow, canwat, xice, vegfra, tmn
    1682. 

  1682. 

  1683.       INTEGER, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: ivgtyp, isltyp
    1684. 

  1684. 

  1685.       INTEGER :: icm,jcm,itf,jtf
    1686. 

  1686.       INTEGER ::  i,j,l
    1687. 

  1687. 

  1688.       itf=min0(ite,ide-1)
    1689. 

  1689.       jtf=min0(jte,jde-1)
    1690. 

  1690. 

  1691.       icm = ide/2
    1692. 

  1692.       jcm = jde/2
    1693. 

  1693. 

  1694.       DO j=jts,jtf
    1695. 

  1695.          DO l=1,num_soil_layers
    1696. 

  1696.             DO i=its,itf
    1697. 

  1697.                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1698. 

  1698.                if (xland(i,j) .lt. 1.5) then
    1699. 

  1699.                smois(i,1,j)=0.30
    1700. 

  1700.                smois(i,2,j)=0.30
    1701. 

  1701.                smois(i,3,j)=0.30
    1702. 

  1702.                smois(i,4,j)=0.30
    1703. 

  1703. 

  1704.                tslb(i,1,j)=290.
    1705. 

  1705.                tslb(i,2,j)=290.
    1706. 

  1706.                tslb(i,3,j)=290.
    1707. 

  1707.                tslb(i,4,j)=290.
    1708. 

  1708.                endif
    1709. 

  1709.             ENDDO
    1710. 

  1710.          ENDDO
    1711. 

  1711.       ENDDO
    1712. 

  1712. 

  1713.    END SUBROUTINE init_soil_2_ideal
    1714. 

  1714. 

  1715.    SUBROUTINE init_soil_3_real ( tsk , tmn , smois , tslb , &
    1716. 

  1716.                                  st_input , sm_input , landmask, sst, &
    1717. 

  1717.                                  zs , dzs , &
    1718. 

  1718.                                  st_levels_input , sm_levels_input , &
    1719. 

  1719.                                  num_soil_layers , num_st_levels_input , num_sm_levels_input ,  &
    1720. 

  1720.                                  num_st_levels_alloc , num_sm_levels_alloc , &
    1721. 

  1721.                                  flag_sst , flag_soil_layers , flag_soil_levels , &
    1722. 

  1722.                                  ids , ide , jds , jde , kds , kde , &
    1723. 

  1723.                                  ims , ime , jms , jme , kms , kme , &
    1724. 

  1724.                                  its , ite , jts , jte , kts , kte )
    1725. 

  1725. 

  1726.       IMPLICIT NONE
    1727. 

  1727. 

  1728.       INTEGER , INTENT(IN) :: num_soil_layers , &
    1729. 

  1729.                               num_st_levels_input , num_sm_levels_input , &
    1730. 

  1730.                               num_st_levels_alloc , num_sm_levels_alloc , &
    1731. 

  1731.                               ids , ide , jds , jde , kds , kde , &
    1732. 

  1732.                               ims , ime , jms , jme , kms , kme , &
    1733. 

  1733.                               its , ite , jts , jte , kts , kte
    1734. 

  1734. 

  1735.       INTEGER , INTENT(IN) :: flag_sst, flag_soil_layers, flag_soil_levels
    1736. 

  1736. 

  1737.       INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input
    1738. 

  1738.       INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input
    1739. 

  1739. 

  1740.       REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input
    1741. 

  1741.       REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input
    1742. 

  1742.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst
    1743. 

  1743. 

  1744.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn
    1745. 

  1745.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk
    1746. 

  1746.       REAL , DIMENSION(num_soil_layers) :: zs , dzs
    1747. 

  1747. 

  1748.       REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois
    1749. 

  1749. 

  1750.       REAL , ALLOCATABLE , DIMENSION(:) :: zhave
    1751. 

  1751. 

  1752.       INTEGER :: i , j , l , lout , lin , lwant , lhave, k
    1753. 

  1753.       REAL :: temp
    1754. 

  1754. 

  1755.       CHARACTER (LEN=132) :: message
    1756. 

  1756. 

  1757.       !  Allocate the soil layer array used for interpolating.
    1758. 

  1758. 

  1759.       IF ( ( num_st_levels_input .LE. 0 ) .OR. &
    1760. 

  1760.            ( num_sm_levels_input .LE. 0 ) ) THEN
    1761. 

  1761.          write (message, FMT='(A)')&
    1762. 

  1762. 'No input soil level data (either temperature or moisture, or both are missing).  Required for RUC LSM.'
    1763. 

  1763.          CALL wrf_error_fatal ( message )
    1764. 

  1764.       ELSE
    1765. 

  1765.          IF ( flag_soil_levels == 1 ) THEN
    1766. 

  1766.            write(message, FMT='(A)') ' Assume RUC LSM 6-level input'
    1767. 

  1767.            CALL wrf_message ( message )
    1768. 

  1768.            ALLOCATE ( zhave( MAX(num_st_levels_input,num_sm_levels_input)  ) )
    1769. 

  1769.          ELSE
    1770. 

  1770.            write(message, FMT='(A)') ' Assume non-RUC LSM input'
    1771. 

  1771.            CALL wrf_message ( message )
    1772. 

  1772.            ALLOCATE ( zhave( MAX(num_st_levels_input,num_soil_layers)  ) )
    1773. 

  1773.          END IF
    1774. 

  1774.       END IF
    1775. 

  1775. 

  1776.       !  Sort the levels for temperature.
    1777. 

  1777. 

  1778.       outert : DO lout = 1 , num_st_levels_input-1
    1779. 

  1779.          innert : DO lin = lout+1 , num_st_levels_input
    1780. 

  1780.             IF ( st_levels_input(lout) .GT. st_levels_input(lin) ) THEN
    1781. 

  1781.                temp = st_levels_input(lout)
    1782. 

  1782.                st_levels_input(lout) = st_levels_input(lin)
    1783. 

  1783.                st_levels_input(lin) = NINT(temp)
    1784. 

  1784.                DO j = jts , MIN(jde-1,jte)
    1785. 

  1785.                   DO i = its , MIN(ide-1,ite)
    1786. 

  1786.                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1787. 

  1787.                      temp = st_input(i,lout,j)
    1788. 

  1788.                      st_input(i,lout,j) = st_input(i,lin,j)
    1789. 

  1789.                      st_input(i,lin,j) = temp
    1790. 

  1790.                   END DO
    1791. 

  1791.                END DO
    1792. 

  1792.             END IF
    1793. 

  1793.          END DO innert
    1794. 

  1794.       END DO outert
    1795. 

  1795. 

  1796.       IF ( flag_soil_layers == 1 ) THEN
    1797. 

  1797.       DO j = jts , MIN(jde-1,jte)
    1798. 

  1798.          DO i = its , MIN(ide-1,ite)
    1799. 

  1799.             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1800. 

  1800.             st_input(i,1,j) = tsk(i,j)
    1801. 

  1801.             st_input(i,num_st_levels_input+2,j) = tmn(i,j)
    1802. 

  1802.          END DO
    1803. 

  1803.       END DO
    1804. 

  1804.       END IF
    1805. 

  1805. 

  1806.       !  Sort the levels for moisture.
    1807. 

  1807. 

  1808.       outerm: DO lout = 1 , num_sm_levels_input-1
    1809. 

  1809.          innerm : DO lin = lout+1 , num_sm_levels_input
    1810. 

  1810.             IF ( sm_levels_input(lout) .GT. sm_levels_input(lin) ) THEN
    1811. 

  1811.                temp = sm_levels_input(lout)
    1812. 

  1812.                sm_levels_input(lout) = sm_levels_input(lin)
    1813. 

  1813.                sm_levels_input(lin) = NINT(temp)
    1814. 

  1814.                DO j = jts , MIN(jde-1,jte)
    1815. 

  1815.                   DO i = its , MIN(ide-1,ite)
    1816. 

  1816.                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1817. 

  1817.                      temp = sm_input(i,lout,j)
    1818. 

  1818.                      sm_input(i,lout,j) = sm_input(i,lin,j)
    1819. 

  1819.                      sm_input(i,lin,j) = temp
    1820. 

  1820.                   END DO
    1821. 

  1821.                END DO
    1822. 

  1822.             END IF
    1823. 

  1823.          END DO innerm
    1824. 

  1824.       END DO outerm
    1825. 

  1825. 

  1826.       IF ( flag_soil_layers == 1 ) THEN
    1827. 

  1827.       DO j = jts , MIN(jde-1,jte)
    1828. 

  1828.          DO i = its , MIN(ide-1,ite)
    1829. 

  1829.             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1830. 

  1830.             sm_input(i,1,j) = (sm_input(i,2,j)-sm_input(i,3,j))/   &
    1831. 

  1831.                               (st_levels_input(2)-st_levels_input(1))*st_levels_input(1)+  &
    1832. 

  1832.                               sm_input(i,2,j)
    1833. 

  1833. !           sm_input(i,1,j) = sm_input(i,2,j)
    1834. 

  1834.             sm_input(i,num_sm_levels_input+2,j) = sm_input(i,num_sm_levels_input+1,j)
    1835. 

  1835.          END DO
    1836. 

  1836.       END DO
    1837. 

  1837.       END IF
    1838. 

  1838. 

  1839.       !  Here are the levels that we have from the input for temperature.
    1840. 

  1840. 

  1841.       IF ( flag_soil_levels == 1 ) THEN
    1842. 

  1842.          DO l = 1 , num_st_levels_input
    1843. 

  1843.             zhave(l) = st_levels_input(l) / 100.
    1844. 

  1844.          END DO
    1845. 

  1845. 

  1846.       !  Interpolate between the layers we have (zhave) and those that we want (zs).
    1847. 

  1847. 

  1848. 

  1849.       z_wantt : DO lwant = 1 , num_soil_layers
    1850. 

  1850.          z_havet : DO lhave = 1 , num_st_levels_input -1
    1851. 

  1851.             IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    1852. 

  1852.                  ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    1853. 

  1853.                DO j = jts , MIN(jde-1,jte)
    1854. 

  1854.                   DO i = its , MIN(ide-1,ite)
    1855. 

  1855.                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1856. 

  1856.                      tslb(i,lwant,j)= ( st_input(i,lhave,j ) * ( zhave(lhave+1) - zs   (lwant) ) + &
    1857. 

  1857.                                         st_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    1858. 

  1858.                                                                 ( zhave(lhave+1) - zhave(lhave) )
    1859. 

  1859.                   END DO
    1860. 

  1860.                END DO
    1861. 

  1861.                EXIT z_havet
    1862. 

  1862.             END IF
    1863. 

  1863.          END DO z_havet
    1864. 

  1864.       END DO z_wantt
    1865. 

  1865. 

  1866.       ELSE
    1867. 

  1867. 

  1868.          zhave(1) = 0.
    1869. 

  1869.          DO l = 1 , num_st_levels_input
    1870. 

  1870.             zhave(l+1) = st_levels_input(l) / 100.
    1871. 

  1871.          END DO
    1872. 

  1872.          zhave(num_st_levels_input+2) = 300. / 100.
    1873. 

  1873. 

  1874.       !  Interpolate between the layers we have (zhave) and those that we want (zs).
    1875. 

  1875. 

  1876.       z_wantt_2 : DO lwant = 1 , num_soil_layers
    1877. 

  1877.          z_havet_2 : DO lhave = 1 , num_st_levels_input +2
    1878. 

  1878.             IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    1879. 

  1879.                  ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    1880. 

  1880.                DO j = jts , MIN(jde-1,jte)
    1881. 

  1881.                   DO i = its , MIN(ide-1,ite)
    1882. 

  1882.                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1883. 

  1883.                      tslb(i,lwant,j)= ( st_input(i,lhave,j ) * ( zhave(lhave+1) - zs   (lwant) ) + &
    1884. 

  1884.                                         st_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    1885. 

  1885.                                                                 ( zhave(lhave+1) - zhave(lhave) )
    1886. 

  1886.                   END DO
    1887. 

  1887.                END DO
    1888. 

  1888.                EXIT z_havet_2
    1889. 

  1889.             END IF
    1890. 

  1890.          END DO z_havet_2
    1891. 

  1891.       END DO z_wantt_2
    1892. 

  1892. 

  1893.       END IF
    1894. 

  1894. 

  1895.       !  Here are the levels that we have from the input for moisture.
    1896. 

  1896. 

  1897.       IF ( flag_soil_levels .EQ. 1 ) THEN
    1898. 

  1898.          DO l = 1 , num_sm_levels_input
    1899. 

  1899.             zhave(l) = sm_levels_input(l) / 100.
    1900. 

  1900.          END DO
    1901. 

  1901. 

  1902.       !  Interpolate between the layers we have (zhave) and those that we want (zs).
    1903. 

  1903. 

  1904.       z_wantm : DO lwant = 1 , num_soil_layers
    1905. 

  1905.          z_havem : DO lhave = 1 , num_sm_levels_input -1
    1906. 

  1906.             IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    1907. 

  1907.                  ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    1908. 

  1908.                DO j = jts , MIN(jde-1,jte)
    1909. 

  1909.                   DO i = its , MIN(ide-1,ite)
    1910. 

  1910.                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1911. 

  1911.                      smois(i,lwant,j)= ( sm_input(i,lhave,j ) * ( zhave(lhave+1) - zs   (lwant) ) + &
    1912. 

  1912.                                          sm_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    1913. 

  1913.                                                                  ( zhave(lhave+1) - zhave(lhave) )
    1914. 

  1914.                   END DO
    1915. 

  1915.                END DO
    1916. 

  1916.                EXIT z_havem
    1917. 

  1917.             END IF
    1918. 

  1918.          END DO z_havem
    1919. 

  1919.       END DO z_wantm
    1920. 

  1920. 

  1921.       ELSE
    1922. 

  1922. 

  1923.          zhave(1) = 0.
    1924. 

  1924.          DO l = 1 , num_sm_levels_input
    1925. 

  1925.             zhave(l+1) = sm_levels_input(l) / 100.
    1926. 

  1926.          END DO
    1927. 

  1927.          zhave(num_sm_levels_input+2) = 300. / 100.
    1928. 

  1928. 

  1929.       z_wantm_2 : DO lwant = 1 , num_soil_layers
    1930. 

  1930.          z_havem_2 : DO lhave = 1 , num_sm_levels_input +2
    1931. 

  1931.             IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    1932. 

  1932.                  ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    1933. 

  1933.                DO j = jts , MIN(jde-1,jte)
    1934. 

  1934.                   DO i = its , MIN(ide-1,ite)
    1935. 

  1935.                      IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1936. 

  1936.                      smois(i,lwant,j)= ( sm_input(i,lhave,j ) * ( zhave(lhave+1) - zs   (lwant) ) + &
    1937. 

  1937.                                          sm_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    1938. 

  1938.                                                                  ( zhave(lhave+1) - zhave(lhave) )
    1939. 

  1939.                   END DO
    1940. 

  1940.                END DO
    1941. 

  1941.                EXIT z_havem_2
    1942. 

  1942.             END IF
    1943. 

  1943.          END DO z_havem_2
    1944. 

  1944.       END DO z_wantm_2
    1945. 

  1945. 

  1946.       END IF
    1947. 

  1947.       !  Over water, put in reasonable values for soil temperature and moisture.  These won't be
    1948. 

  1948.       !  used, but they will make a more continuous plot.
    1949. 

  1949. 

  1950.       IF ( flag_sst .EQ. 1 ) THEN
    1951. 

  1951.          DO j = jts , MIN(jde-1,jte)
    1952. 

  1952.             DO i = its , MIN(ide-1,ite)
    1953. 

  1953.                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1954. 

  1954.                IF ( landmask(i,j) .LT. 0.5 ) THEN
    1955. 

  1955.                   DO l = 1 , num_soil_layers
    1956. 

  1956.                      tslb(i,l,j) = sst(i,j)
    1957. 

  1957.                      tsk(i,j)    = sst(i,j)
    1958. 

  1958.                      smois(i,l,j)= 1.0
    1959. 

  1959.                   END DO
    1960. 

  1960.                END IF
    1961. 

  1961.             END DO
    1962. 

  1962.          END DO
    1963. 

  1963.       ELSE
    1964. 

  1964.          DO j = jts , MIN(jde-1,jte)
    1965. 

  1965.             DO i = its , MIN(ide-1,ite)
    1966. 

  1966.                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    1967. 

  1967.                IF ( landmask(i,j) .LT. 0.5 ) THEN
    1968. 

  1968.                   DO l = 1 , num_soil_layers
    1969. 

  1969.                      tslb(i,l,j)= tsk(i,j)
    1970. 

  1970.                      smois(i,l,j)= 1.0
    1971. 

  1971.                   END DO
    1972. 

  1972.                END IF
    1973. 

  1973.             END DO
    1974. 

  1974.          END DO
    1975. 

  1975.       END IF
    1976. 

  1976. 

  1977.       DEALLOCATE (zhave)
    1978. 

  1978. 

  1979.    END SUBROUTINE init_soil_3_real
    1980. 

  1980.    SUBROUTINE init_soil_7_real ( tsk , tmn , smois , sh2o , tslb , &
    1981. 

  1981.                                  st_input , sm_input , sw_input , landmask , sst ,     &
    1982. 

  1982.                                  zs , dzs ,                                            &
    1983. 

  1983.                                  st_levels_input , sm_levels_input , sw_levels_input , &
    1984. 

  1984.                                  num_soil_layers , num_st_levels_input ,               &
    1985. 

  1985.                                  num_sm_levels_input ,  num_sw_levels_input ,          &
    1986. 

  1986.                                  num_st_levels_alloc , num_sm_levels_alloc ,           &
    1987. 

  1987.                                  num_sw_levels_alloc ,                                 &
    1988. 

  1988.                                  flag_sst , flag_soil_layers , flag_soil_levels ,      &
    1989. 

  1989.                                  ids , ide , jds , jde , kds , kde ,                   &
    1990. 

  1990.                                  ims , ime , jms , jme , kms , kme ,                   &
    1991. 

  1991.                                  its , ite , jts , jte , kts , kte )
    1992. 

  1992. 

  1993.       ! for soil temperature and moisture initialization for the PX LSM
    1994. 

  1994. 

  1995.       IMPLICIT NONE
    1996. 

  1996. 

  1997.       INTEGER , INTENT(IN) :: num_soil_layers , &
    1998. 

  1998.                               num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
    1999. 

  1999.                               num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , &
    2000. 

  2000.                               ids , ide , jds , jde , kds , kde , &
    2001. 

  2001.                               ims , ime , jms , jme , kms , kme , &
    2002. 

  2002.                               its , ite , jts , jte , kts , kte
    2003. 

  2003. 

  2004.       INTEGER , INTENT(IN) :: flag_sst, flag_soil_layers, flag_soil_levels
    2005. 

  2005. 

  2006.       INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input
    2007. 

  2007.       INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input
    2008. 

  2008.       INTEGER , DIMENSION(1:num_sw_levels_input) , INTENT(INOUT) :: sw_levels_input
    2009. 

  2009. 

  2010.       REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input
    2011. 

  2011.       REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input
    2012. 

  2012.       REAL , DIMENSION(ims:ime,1:num_sw_levels_alloc,jms:jme) , INTENT(INOUT) :: sw_input
    2013. 

  2013.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst
    2014. 

  2014. 

  2015.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn
    2016. 

  2016.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk
    2017. 

  2017.       REAL , DIMENSION(num_soil_layers) :: zs , dzs
    2018. 

  2018. 

  2019.       REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois , sh2o
    2020. 

  2020. 

  2021.       REAL , ALLOCATABLE , DIMENSION(:) :: zhave
    2022. 

  2022. 

  2023.       INTEGER :: i , j , l , lout , lin , lwant , lhave , num
    2024. 

  2024.       REAL    :: temp
    2025. 

  2025.       LOGICAL :: found_levels
    2026. 

  2026. 

  2027.       !  Are there any soil temp and moisture levels - ya know, they are mandatory.
    2028. 

  2028. 

  2029.       num = num_st_levels_input * num_sm_levels_input
    2030. 

  2030. 

  2031.       IF ( num .GE. 1 ) THEN
    2032. 

  2032. 

  2033.          !  Ordered levels that we have data for.
    2034. 

  2034. 

  2035.          ALLOCATE ( zhave( MAX(num_st_levels_input,num_sm_levels_input,num_sw_levels_input) +2) )
    2036. 

  2036. 

  2037.          !  Sort the levels for temperature.
    2038. 

  2038.          outert : DO lout = 1 , num_st_levels_input-1
    2039. 

  2039.             innert : DO lin = lout+1 , num_st_levels_input
    2040. 

  2040.                IF ( st_levels_input(lout) .GT. st_levels_input(lin) ) THEN
    2041. 

  2041.                   temp = st_levels_input(lout)
    2042. 

  2042.                   st_levels_input(lout) = st_levels_input(lin)
    2043. 

  2043.                   st_levels_input(lin) = NINT(temp)
    2044. 

  2044.                   DO j = jts , MIN(jde-1,jte)
    2045. 

  2045.                      DO i = its , MIN(ide-1,ite)
    2046. 

  2046.                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    2047. 

  2047.                         temp = st_input(i,lout+1,j)
    2048. 

  2048.                         st_input(i,lout+1,j) = st_input(i,lin+1,j)
    2049. 

  2049.                         st_input(i,lin+1,j) = temp
    2050. 

  2050.                      END DO
    2051. 

  2051.                   END DO
    2052. 

  2052.                END IF
    2053. 

  2053.             END DO innert
    2054. 

  2054.          END DO outert
    2055. 

  2055.          DO j = jts , MIN(jde-1,jte)
    2056. 

  2056.             DO i = its , MIN(ide-1,ite)
    2057. 

  2057.                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    2058. 

  2058.                st_input(i,1,j) = tsk(i,j)
    2059. 

  2059.                st_input(i,num_st_levels_input+2,j) = tmn(i,j)
    2060. 

  2060.             END DO
    2061. 

  2061.          END DO
    2062. 

  2062. 

  2063.          !  Sort the levels for moisture.
    2064. 

  2064. 

  2065.          outerm: DO lout = 1 , num_sm_levels_input-1
    2066. 

  2066.             innerm : DO lin = lout+1 , num_sm_levels_input
    2067. 

  2067.               IF ( sm_levels_input(lout) .GT. sm_levels_input(lin) ) THEN
    2068. 

  2068.                   temp = sm_levels_input(lout)
    2069. 

  2069.                   sm_levels_input(lout) = sm_levels_input(lin)
    2070. 

  2070.                   sm_levels_input(lin) = NINT(temp)
    2071. 

  2071.                   DO j = jts , MIN(jde-1,jte)
    2072. 

  2072.                      DO i = its , MIN(ide-1,ite)
    2073. 

  2073.                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    2074. 

  2074.                         temp = sm_input(i,lout+1,j)
    2075. 

  2075.                         sm_input(i,lout+1,j) = sm_input(i,lin+1,j)
    2076. 

  2076.                         sm_input(i,lin+1,j) = temp
    2077. 

  2077.                      END DO
    2078. 

  2078.                   END DO
    2079. 

  2079.                END IF
    2080. 

  2080.             END DO innerm
    2081. 

  2081.          END DO outerm
    2082. 

  2082.          DO j = jts , MIN(jde-1,jte)
    2083. 

  2083.             DO i = its , MIN(ide-1,ite)
    2084. 

  2084.                IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    2085. 

  2085.                sm_input(i,1,j) = sm_input(i,2,j)
    2086. 

  2086.                sm_input(i,num_sm_levels_input+2,j) = sm_input(i,num_sm_levels_input+1,j)
    2087. 

  2087.             END DO
    2088. 

  2088.          END DO
    2089. 

  2089. 

  2090.          !  Sort the levels for liquid moisture.
    2091. 

  2091. 

  2092.          outerw: DO lout = 1 , num_sw_levels_input-1
    2093. 

  2093.             innerw : DO lin = lout+1 , num_sw_levels_input
    2094. 

  2094.                IF ( sw_levels_input(lout) .GT. sw_levels_input(lin) ) THEN
    2095. 

  2095.                   temp = sw_levels_input(lout)
    2096. 

  2096.                   sw_levels_input(lout) = sw_levels_input(lin)
    2097. 

  2097.                   sw_levels_input(lin) = NINT(temp)
    2098. 

  2098.                   DO j = jts , MIN(jde-1,jte)
    2099. 

  2099.                      DO i = its , MIN(ide-1,ite)
    2100. 

  2100.                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    2101. 

  2101.                         temp = sw_input(i,lout+1,j)
    2102. 

  2102.                         sw_input(i,lout+1,j) = sw_input(i,lin+1,j)
    2103. 

  2103.                         sw_input(i,lin+1,j) = temp
    2104. 

  2104.                      END DO
    2105. 

  2105.                   END DO
    2106. 

  2106.                END IF
    2107. 

  2107.             END DO innerw
    2108. 

  2108.          END DO outerw
    2109. 

  2109.         IF ( num_sw_levels_input .GT. 1 ) THEN
    2110. 

  2110.             DO j = jts , MIN(jde-1,jte)
    2111. 

  2111.                DO i = its , MIN(ide-1,ite)
    2112. 

  2112.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    2113. 

  2113.                   sw_input(i,1,j) = sw_input(i,2,j)
    2114. 

  2114.                   sw_input(i,num_sw_levels_input+2,j) = sw_input(i,num_sw_levels_input+1,j)
    2115. 

  2115.                END DO
    2116. 

  2116.             END DO
    2117. 

  2117.          END IF
    2118. 

  2118. 

  2119.          found_levels = .TRUE.
    2120. 

  2120. 

  2121.       ELSE IF ( ( num .LE. 0 ) .AND. (  start_date .NE. current_date ) ) THEN
    2122. 

  2122. 

  2123.          found_levels = .FALSE.
    2124. 

  2124. 

  2125.       ELSE
    2126. 

  2126.          CALL wrf_error_fatal ( &
    2127. 

  2127.          'No input soil level data (temperature, moisture or liquid, or all are missing). Required for PX LSM.' )
    2128. 

  2128.       END IF
    2129. 

  2129. 

  2130.       !  Is it OK to continue?
    2131. 

  2131. 

  2132.       IF ( found_levels ) THEN
    2133. 

  2133. 

  2134.          !  Here are the levels that we have from the input for temperature.  The input levels plus
    2135. 

  2135.          !  two more: the skin temperature at 0 cm, and the annual mean temperature at 300 cm.
    2136. 

  2136. 

  2137.          zhave(1) = 0.
    2138. 

  2138.          DO l = 1 , num_st_levels_input
    2139. 

  2139.             zhave(l+1) = st_levels_input(l) / 100.
    2140. 

  2140.         END DO
    2141. 

  2141.          zhave(num_st_levels_input+2) = 300. / 100.
    2142. 

  2142. 

  2143.          !  Interpolate between the layers we have (zhave) and those that we want (zs).
    2144. 

  2144. 

  2145.          z_wantt : DO lwant = 1 , num_soil_layers
    2146. 

  2146.             z_havet : DO lhave = 1 , num_st_levels_input +2 -1
    2147. 

  2147.                IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    2148. 

  2148.                     ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    2149. 

  2149.                   DO j = jts , MIN(jde-1,jte)
    2150. 

  2150.                      DO i = its , MIN(ide-1,ite)
    2151. 

  2151.                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    2152. 

  2152.                         tslb(i,lwant,j)= ( st_input(i,lhave  ,j) * ( zhave(lhave+1) - zs   (lwant) ) + &
    2153. 

  2153.                                            st_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    2154. 

  2154.                                                                    ( zhave(lhave+1) - zhave(lhave) )
    2155. 

  2155.                      END DO
    2156. 

  2156.                   END DO
    2157. 

  2157.                   EXIT z_havet
    2158. 

  2158.                END IF
    2159. 

  2159.             END DO z_havet
    2160. 

  2160.          END DO z_wantt
    2161. 

  2161. 

  2162.          !  Here are the levels that we have from the input for moisture.  The input levels plus
    2163. 

  2163.          !  two more: a value at 0 cm and one at 300 cm.  The 0 cm value is taken to be identical
    2164. 

  2164.          !  to the most shallow layer's value.  Similarly, the 300 cm value is taken to be the same
    2165. 

  2165.          !  as the most deep layer's value.
    2166. 

    2167. 

  2167.          zhave(1) = 0.
    2168. 

  2168.          DO l = 1 , num_sm_levels_input
    2169. 

  2169.             zhave(l+1) = sm_levels_input(l) / 100.
    2170. 

  2170.          END DO
    2171. 

  2171.         zhave(num_sm_levels_input+2) = 300. / 100.
    2172. 

  2172. 

  2173.          !  Interpolate between the layers we have (zhave) and those that we want (zs).
    2174. 

  2174. 

  2175.          z_wantm : DO lwant = 1 , num_soil_layers
    2176. 

  2176.             z_havem : DO lhave = 1 , num_sm_levels_input +2 -1
    2177. 

  2177.                IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    2178. 

  2178.                     ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    2179. 

  2179.                   DO j = jts , MIN(jde-1,jte)
    2180. 

  2180.                      DO i = its , MIN(ide-1,ite)
    2181. 

  2181.                         IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    2182. 

  2182.                         smois(i,lwant,j)= ( sm_input(i,lhave  ,j) * ( zhave(lhave+1) - zs   (lwant) ) + &
    2183. 

  2183.                                             sm_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    2184. 

  2184.                                                                     ( zhave(lhave+1) - zhave(lhave) )
    2185. 

  2185.                      END DO
    2186. 

  2186.                   END DO
    2187. 

  2187.                   EXIT z_havem
    2188. 

  2188.                END IF
    2189. 

  2189.             END DO z_havem
    2190. 

  2190.          END DO z_wantm
    2191. 

  2191. 

  2192.          !  Any liquid soil moisture to worry about?
    2193. 

  2193. 

  2194.          IF ( num_sw_levels_input .GT. 1 ) THEN
    2195. 

  2195. 

  2196.             zhave(1) = 0.
    2197. 

  2197.             DO l = 1 , num_sw_levels_input
    2198. 

  2198.                zhave(l+1) = sw_levels_input(l) / 100.
    2199. 

  2199.             END DO
    2200. 

  2200.             zhave(num_sw_levels_input+2) = 300. / 100.
    2201. 

  2201. 

  2202.           !  Interpolate between the layers we have (zhave) and those that we want (zs).
    2203. 

  2203. 

  2204.             z_wantw : DO lwant = 1 , num_soil_layers
    2205. 

  2205.                z_havew : DO lhave = 1 , num_sw_levels_input +2 -1
    2206. 

  2206.                   IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    2207. 

  2207.                        ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    2208. 

  2208.                      DO j = jts , MIN(jde-1,jte)
    2209. 

  2209.                         DO i = its , MIN(ide-1,ite)
    2210. 

  2210.                            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    2211. 

  2211.                            sh2o(i,lwant,j)= ( sw_input(i,lhave  ,j) * ( zhave(lhave+1) - zs   (lwant) ) + &
    2212. 

  2212.                                                sw_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    2213. 

  2213.                                                                        ( zhave(lhave+1) - zhave(lhave) )
    2214. 

  2214.                         END DO
    2215. 

  2215.                      END DO
    2216. 

  2216.                      EXIT z_havew
    2217. 

  2217.                   END IF
    2218. 

  2218.                END DO z_havew
    2219. 

  2219.             END DO z_wantw
    2220. 

  2220. 

  2221.          END IF
    2222. 

  2222. 

  2223. 

  2224.         !  Over water, put in reasonable values for soil temperature and moisture.  These won't be
    2225. 

  2225.         !  used, but they will make a more continuous plot.
    2226. 

  2226. 

  2227.      DO j = jts , MIN(jde-1,jte)
    2228. 

  2228.         DO i = its , MIN(ide-1,ite)
    2229. 

  2229.              IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    2230. 

  2230.              tslb(i,1,j)= tsk(i,j)
    2231. 

  2231.              tslb(i,2,j)= tmn(i,j)
    2232. 

  2232.         END DO
    2233. 

  2233.      END DO
    2234. 

  2234. 

  2235.          IF ( flag_sst .EQ. 1 ) THEN
    2236. 

  2236.             DO j = jts , MIN(jde-1,jte)
    2237. 

  2237.                DO i = its , MIN(ide-1,ite)
    2238. 

  2238.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    2239. 

  2239.                   IF ( landmask(i,j) .LT. 0.5 ) THEN
    2240. 

  2240.                      DO l = 1 , num_soil_layers
    2241. 

  2241.                         tslb(i,l,j)= sst(i,j)
    2242. 

  2242.                         smois(i,l,j)= 1.0
    2243. 

  2243.                         sh2o (i,l,j)= 1.0
    2244. 

  2244.                      END DO
    2245. 

  2245.                   END IF
    2246. 

  2246.                END DO
    2247. 

  2247.             END DO
    2248. 

  2248.          ELSE
    2249. 

  2249.             DO j = jts , MIN(jde-1,jte)
    2250. 

  2250.                DO i = its , MIN(ide-1,ite)
    2251. 

  2251.                   IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
    2252. 

  2252.                   IF ( landmask(i,j) .LT. 0.5 ) THEN
    2253. 

  2253.                      DO l = 1 , num_soil_layers
    2254. 

  2254.                         tslb(i,l,j)= tsk(i,j)
    2255. 

  2255.                         smois(i,l,j)= 1.0
    2256. 

  2256.                         sh2o (i,l,j)= 1.0
    2257. 

  2257.                      END DO
    2258. 

  2258.                   END IF
    2259. 

  2259.                END DO
    2260. 

  2260.             END DO
    2261. 

  2261.          END IF
    2262. 

  2262. 

  2263.          DEALLOCATE (zhave)
    2264. 

  2264. 

  2265.       END IF
    2266. 

  2266. 

  2267.    END SUBROUTINE init_soil_7_real
    2268. 

  2268. !------------SSIB (fds 06/2010)-----------------------------
    2269. 

  2269.    SUBROUTINE init_soil_8_real ( tsk , tmn , smois , sh2o , tslb , &
    2270. 

  2270.                                  st_input , sm_input , sw_input , landmask , sst , &
    2271. 

  2271.                                  zs , dzs , &
    2272. 

  2272.                                  st_levels_input , sm_levels_input , sw_levels_input , &
    2273. 

  2273.            num_soil_layers , num_st_levels_input , num_sm_levels_input ,  num_sw_levels_input , &
    2274. 

  2274.                              num_st_levels_alloc , num_sm_levels_alloc ,  num_sw_levels_alloc , &
    2275. 

  2275.                                  flag_sst , flag_soil_layers , flag_soil_levels , &
    2276. 

  2276.                                  st000010, st010200, sm000010, sm010200, &
    2277. 

  2277.                                  st010040 , st040100 , st100200, &
    2278. 

  2278.                                  sm010040 , sm040100 , sm100200, &
    2279. 

  2279.                                  ids , ide , jds , jde , kds , kde , &
    2280. 

  2280.                                  ims , ime , jms , jme , kms , kme , &
    2281. 

  2281.                                  its , ite , jts , jte , kts , kte )
    2282. 

  2282. 

  2283.       IMPLICIT NONE
    2284. 

  2284. 

  2285.       INTEGER , INTENT(IN) :: num_soil_layers , &
    2286. 

  2286.                               num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
    2287. 

  2287.                               num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , &
    2288. 

  2288.                               ids , ide , jds , jde , kds , kde , &
    2289. 

  2289.                               ims , ime , jms , jme , kms , kme , &
    2290. 

  2290.                               its , ite , jts , jte , kts , kte
    2291. 

  2291. 

  2292.       INTEGER , INTENT(IN) :: flag_sst, flag_soil_layers , flag_soil_levels
    2293. 

  2293. 

  2294.       INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input
    2295. 

  2295.       INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input
    2296. 

  2296.       INTEGER , DIMENSION(1:num_sw_levels_input) , INTENT(INOUT) :: sw_levels_input
    2297. 

  2297. 

  2298.       REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input
    2299. 

  2299.       REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input
    2300. 

  2300.       REAL , DIMENSION(ims:ime,1:num_sw_levels_alloc,jms:jme) , INTENT(INOUT) :: sw_input
    2301. 

  2301.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst
    2302. 

  2302.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: st000010, st010200, st010040 , st040100 , st100200
    2303. 

  2303.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: sm000010, sm010200, sm010040 , sm040100 , sm100200
    2304. 

  2304. 

  2305.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn
    2306. 

  2306.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk
    2307. 

  2307.       REAL , DIMENSION(num_soil_layers) :: zs , dzs
    2308. 

  2308. 

  2309.       REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois , sh2o
    2310. 

  2310. 

  2311.       REAL , ALLOCATABLE , DIMENSION(:) :: zhave
    2312. 

  2312. 

  2313.       INTEGER :: i , j , l , lout , lin , lwant , lhave , num
    2314. 

  2314.       REAL :: temp
    2315. 

  2315.       LOGICAL :: found_levels
    2316. 

  2316. 

  2317.       found_levels = .false.
    2318. 

  2318. 

  2319. !      write(message, FMT='(A)') ' Prepare SSiB LSM soil fields'
    2320. 

  2320. !fds (06/2010)
    2321. 

  2321. !-- SSiB needs NCEP/NCAR reanalysis soil temperature and moisture at 0-10cm and 10-200cm --
    2322. 

  2322.       IF ( flag_soil_layers == 1 ) THEN
    2323. 

  2323.                   DO j = jts , MIN(jde-1,jte)
    2324. 

  2324.                      DO i = its , MIN(ide-1,ite)
    2325. 

  2325.                         tslb(i,1,j) = st000010(i,j)
    2326. 

  2326.                         tslb(i,2,j) = st010040(i,j)
    2327. 

  2327.                         tslb(i,3,j) = st040100(i,j)
    2328. 

  2328.                         smois(i,1,j) = sm000010(i,j)
    2329. 

  2329.                         smois(i,2,j) = sm010040(i,j)
    2330. 

  2330.                         smois(i,3,j) = sm040100(i,j)
    2331. 

  2331. ! temporary fix (JD) for missing 4-layer input - use 2 instead
    2332. 

  2332.                         if(tslb(i,2,j) .lt. 10.)tslb(i,2,j) = st000010(i,j)
    2333. 

  2333.                         if(smois(i,2,j) .lt. 0.01)smois(i,2,j) = sm000010(i,j)
    2334. 

  2334.                         if(tslb(i,3,j) .lt. 10.)tslb(i,3,j) = st010200(i,j)
    2335. 

  2335.                         if(smois(i,3,j) .lt. 0.01)smois(i,3,j) = sm010200(i,j)
    2336. 

  2336.                      END DO
    2337. 

  2337.                   END DO
    2338. 

  2338.       ELSE
    2339. 

  2339.           CALL wrf_debug ( 0 , 'SSiB LSM needs 0-10 cm soil t')
    2340. 

  2340.           CALL wrf_debug ( 0 , 'SSiB LSM needs 0-10 cm soil m')
    2341. 

  2341.           CALL wrf_debug ( 0 , 'SSiB LSM needs 10-200 cm soil t')
    2342. 

  2342.           CALL wrf_debug ( 0 , 'SSiB LSM needs 10-200 cm soil m')
    2343. 

  2343.       ENDIF
    2344. 

  2344. 

  2345.          !  Over water, put in reasonable values for soil temperature and moisture.  These won't be
    2346. 

  2346.          !  used, but they will make a more continuous plot.
    2347. 

  2347. 

  2348.          IF ( flag_sst .EQ. 1 ) THEN
    2349. 

  2349.             DO j = jts , MIN(jde-1,jte)
    2350. 

  2350.                DO i = its , MIN(ide-1,ite)
    2351. 

  2351.                   IF ( landmask(i,j) .LT. 0.5 ) THEN
    2352. 

  2352.                      DO l = 1 , num_soil_layers
    2353. 

  2353.                         tslb(i,l,j)= sst(i,j)
    2354. 

  2354.                         smois(i,l,j)= 1.0
    2355. 

  2355.                         sh2o (i,l,j)= 1.0
    2356. 

  2356.                      END DO
    2357. 

  2357.                   END IF
    2358. 

  2358.                END DO
    2359. 

  2359.             END DO
    2360. 

  2360.          ELSE
    2361. 

  2361.             DO j = jts , MIN(jde-1,jte)
    2362. 

  2362.                DO i = its , MIN(ide-1,ite)
    2363. 

  2363.                   IF ( landmask(i,j) .LT. 0.5 ) THEN
    2364. 

  2364.                      DO l = 1 , num_soil_layers
    2365. 

  2365.                         tslb(i,l,j)= tsk(i,j)
    2366. 

  2366.                         smois(i,l,j)= 1.0
    2367. 

  2367.                         sh2o (i,l,j)= 1.0
    2368. 

  2368.                      END DO
    2369. 

  2369.                   END IF
    2370. 

  2370.                END DO
    2371. 

  2371.             END DO
    2372. 

  2372.          END IF
    2373. 

  2373. 

  2374.    END SUBROUTINE init_soil_8_real
    2375. 

  2375. !--------------------------------------------------------
    2376. 

  2376. 

  2377.    SUBROUTINE aggregate_categories_part1  ( landuse_frac , iswater , num_veg_cat , mminlu )
    2378. 

  2378.       IMPLICIT NONE
    2379. 

  2379.       INTEGER , INTENT(IN) :: iswater
    2380. 

  2380.       INTEGER , INTENT(IN) :: num_veg_cat
    2381. 

  2381.       CHARACTER (LEN=4) , INTENT(IN) :: mminlu
    2382. 

  2382.       REAL , DIMENSION(1:num_veg_cat) , INTENT(INOUT):: landuse_frac
    2383. 

  2383. 

  2384.       !  Local variables
    2385. 

  2385. 

  2386.       INTEGER , PARAMETER :: num_special_bins =  3 ! grass, shrubs, trees; add a new line in the "cib" array if updating this
    2387. 

  2387.       INTEGER , PARAMETER :: max_cats_per_bin =  8 ! larger than max num of cats inside each of the special bins
    2388. 

  2388.                                                    ! So, no more than 8 total tree categories that we need to consider.
    2389. 

  2389.       INTEGER , PARAMETER :: fl               = -1 ! Flag value so that we know this is not a valid category to consider.
    2390. 

  2390.       INTEGER , DIMENSION ( max_cats_per_bin * num_special_bins ) :: cib_usgs = &
    2391. 

  2391.       (/  2 ,  3 ,  4 ,  5 ,  6 ,  7 , 10 , fl , & ! grass
    2392. 

  2392.           8 ,  9 , fl , fl , fl , fl , fl , fl , & ! shrubs 
    2393. 

  2393.          11 , 12 , 13 , 14 , 15 , fl , fl , fl /)  ! trees
    2394. 

  2394.       INTEGER , DIMENSION ( max_cats_per_bin * num_special_bins ) :: cib_modis = &
    2395. 

  2395.       (/  9 , 10 , 12 , 14 , fl , fl , fl , fl , & ! grass
    2396. 

  2396.           6 ,  7 ,  8 , fl , fl , fl , fl , fl , & ! shrubs 
    2397. 

  2397.           1 ,  2 ,  3 ,  4 ,  5 , fl , fl , fl /)  ! trees
    2398. 

  2398.  
    2399. 

  2399.       IF      ( mminlu(1:4) .EQ. 'USGS' ) THEN
    2400. 

  2400.          CALL aggregate_categories_part2  ( landuse_frac , iswater , num_veg_cat , &
    2401. 

  2401.                                             num_special_bins , max_cats_per_bin , fl , cib_usgs  )
    2402. 

  2402.       ELSE IF ( mminlu(1:4) .EQ. 'MODI' ) THEN
    2403. 

  2403.          CALL aggregate_categories_part2  ( landuse_frac , iswater , num_veg_cat , &
    2404. 

  2404.                                             num_special_bins , max_cats_per_bin , fl , cib_modis )
    2405. 

  2405.       END IF
    2406. 

  2406. 

  2407.    END SUBROUTINE aggregate_categories_part1
    2408. 

  2408. 

  2409.    SUBROUTINE aggregate_categories_part2  ( landuse_frac , iswater , num_veg_cat , &
    2410. 

  2410.                                             num_special_bins , max_cats_per_bin , fl , cib )
    2411. 

  2411.       IMPLICIT NONE
    2412. 

  2412. 

  2413.       INTEGER , INTENT(IN) :: iswater
    2414. 

  2414.       INTEGER , INTENT(IN) :: num_veg_cat
    2415. 

  2415.       REAL , DIMENSION(1:num_veg_cat) , INTENT(INOUT):: landuse_frac
    2416. 

  2416.       INTEGER , INTENT(IN) :: num_special_bins , max_cats_per_bin , fl
    2417. 

  2417.       INTEGER , DIMENSION ( max_cats_per_bin * num_special_bins ) , INTENT(IN) :: cib
    2418. 

  2418. 

  2419.       !  Local variables
    2420. 

  2420. 

  2421.       REAL , DIMENSION(1:num_veg_cat) :: landuse_frac_work ! copy of the input array, allows us to be wreckless
    2422. 

  2422.       INTEGER , DIMENSION ( max_cats_per_bin , num_special_bins ) :: cats_in_bin
    2423. 

  2423.       INTEGER :: ib , ic ! indexes for the bin and the category loops
    2424. 

  2424.       REAL    , DIMENSION ( num_special_bins ) :: bin_max_val , bin_sum ! max category value in this bin, sum of all cats in this bin
    2425. 

  2425.       INTEGER , DIMENSION ( num_special_bins ) :: bin_max_idx ! index of this maximum category in this bin
    2426. 

  2426.       INTEGER :: bin_work , bin_orig ! the bin from whence the maximum hails, respectively for the aggregated and the original data
    2427. 

  2427.       INTEGER :: max_cat_orig , max_cat_work
    2428. 

  2428.       REAL    :: max_val_orig , max_val_work
    2429. 

  2429. 

  2430.       !  Find the max in the original.  If it is >= 50%, no need to even be in here.
    2431. 

  2431. 

  2432.       DO ic = 1 , num_veg_cat
    2433. 

  2433.          IF ( landuse_frac(ic) .GE. 0.5 ) THEN
    2434. 

  2434.             RETURN
    2435. 

  2435.          END IF
    2436. 

  2436.       END DO
    2437. 

  2437. 

  2438.       !  Put the categories in the bin into a 2d array.
    2439. 

  2439. 

  2440.       cats_in_bin = RESHAPE ( cib , (/  max_cats_per_bin , num_special_bins /) )
    2441. 

  2441. 

  2442.       !  Make a copy of the incoming array so that we can eventually diff our working copy with
    2443. 

  2443.       !  the original.
    2444. 

  2444. 

  2445.       landuse_frac_work = landuse_frac
    2446. 

  2446. 

  2447.       !  Loop over each of the special bins that we know about.  Find the max values and the locations of such.
    2448. 

  2448. 

  2449.       DO ib = 1 , num_special_bins
    2450. 

  2450. 

  2451.          !  For this bin, we know about specific categories.  We get the sum of all of those
    2452. 

  2452.          !  categories that we know about for this bin, and we keep track of which category
    2453. 

  2453.          !  is dominant.
    2454. 

  2454. 

  2455.          bin_sum    (ib) =  0
    2456. 

  2456.          bin_max_val(ib) = fl
    2457. 

  2457. 

  2458.          cat_loop_accumulate : DO ic = 1 , max_cats_per_bin
    2459. 

  2459.             
    2460. 

  2460.             !  Have we run out of valid categories in this bin?  For example, we would not necessarily have
    2461. 

  2461.             !  the same number of tree categories as there are grass categories.
    2462. 

  2462.       
    2463. 

  2463.             IF      ( cats_in_bin(ic,ib) .EQ. fl ) THEN
    2464. 

  2464.                EXIT cat_loop_accumulate
    2465. 

  2465.             END IF
    2466. 

  2466. 

  2467.             bin_sum(ib) = bin_sum(ib) + landuse_frac(cats_in_bin(ic,ib))
    2468. 

  2468. 

  2469.             IF ( landuse_frac(cats_in_bin(ic,ib)) .GT. bin_max_val(ib) ) THEN
    2470. 

  2470.                bin_max_val(ib) = landuse_frac(cats_in_bin(ic,ib))
    2471. 

  2471.                bin_max_idx(ib) = cats_in_bin(ic,ib)
    2472. 

  2472.             END IF
    2473. 

  2473. 

  2474.          END DO cat_loop_accumulate
    2475. 

  2475. 

  2476.          cat_loop_assign : DO ic = 1 , max_cats_per_bin
    2477. 

  2477.             
    2478. 

  2478.             !  Plow through each cat in the bin.  If we find the dominant one, he gets the total sum.  If we land on
    2479. 

  2479.             !  the other guys in the bin, they get set back to zero to maintain the original aggregate influence.
    2480. 

  2480.       
    2481. 

  2481.             IF      ( cats_in_bin(ic,ib) .EQ. fl ) THEN
    2482. 

  2482.                EXIT cat_loop_assign
    2483. 

  2483.             ELSE IF ( cats_in_bin(ic,ib) .EQ. bin_max_idx(ib) ) THEN
    2484. 

  2484.                landuse_frac_work(cats_in_bin(ic,ib)) = bin_sum(ib)
    2485. 

  2485.             ELSE
    2486. 

  2486.                landuse_frac_work(cats_in_bin(ic,ib)) = 0
    2487. 

  2487.             END IF
    2488. 

  2488. 

  2489.          END DO cat_loop_assign
    2490. 

  2490. 

  2491.       END DO
    2492. 

  2492. 

  2493.       !  Now we loop through the categorical data, and get the max+location for the original input data and the
    2494. 

  2494.       !  modified work data.  Water is not allowed to be a "max" category unless it is greater than 50%.  We hit 
    2495. 

  2495.       !  that test up at the top already, so we can toss out water willy nilly here.
    2496. 

  2496. 

  2497.       max_cat_orig = fl
    2498. 

  2498.       max_val_orig =  0
    2499. 

  2499.       max_cat_work = fl
    2500. 

  2500.       max_val_work =  0
    2501. 

  2501. 

  2502.       DO ic = 1 , num_veg_cat
    2503. 

  2503.          IF ( ic .EQ. iswater ) THEN
    2504. 

  2504.             CYCLE
    2505. 

  2505.          END IF
    2506. 

  2506.          IF ( landuse_frac(ic) .GT. max_val_orig ) THEN
    2507. 

  2507.             max_val_orig = landuse_frac(ic)
    2508. 

  2508.             max_cat_orig = ic
    2509. 

  2509.          END IF
    2510. 

  2510.          IF ( landuse_frac_work(ic) .GT. max_val_work ) THEN
    2511. 

  2511.             max_val_work = landuse_frac_work(ic)
    2512. 

  2512.             max_cat_work = ic
    2513. 

  2513.          END IF
    2514. 

  2514.       END DO
    2515. 

  2515. 

  2516.       !  Find the bin for the maximimum value of the original data.
    2517. 

  2517. 

  2518.       bin_orig = -1
    2519. 

  2519.       bin_loop_orig : DO ib = 1 , num_special_bins
    2520. 

  2520.          cat_loop_orig : DO ic = 1 , max_cats_per_bin
    2521. 

  2521.             IF      ( cats_in_bin(ic,ib) .EQ. fl           ) THEN
    2522. 

  2522.                EXIT cat_loop_orig
    2523. 

  2523.             ELSE IF ( cats_in_bin(ic,ib) .EQ. max_cat_orig ) THEN
    2524. 

  2524.                bin_orig = ib
    2525. 

  2525.                EXIT bin_loop_orig
    2526. 

  2526.             END IF
    2527. 

  2527.          END DO cat_loop_orig
    2528. 

  2528.       END DO bin_loop_orig
    2529. 

  2529. 

  2530.       !  Find the bin for the maximimum value of the aggregated data.
    2531. 

  2531. 

  2532.       bin_work = -1
    2533. 

  2533.       bin_loop_work : DO ib = 1 , num_special_bins
    2534. 

  2534.          cat_loop_work : DO ic = 1 , max_cats_per_bin
    2535. 

  2535.             IF      ( cats_in_bin(ic,ib) .EQ. fl           ) THEN
    2536. 

  2536.                EXIT cat_loop_work
    2537. 

  2537.             ELSE IF ( cats_in_bin(ic,ib) .EQ. max_cat_work ) THEN
    2538. 

  2538.                bin_work = ib
    2539. 

  2539.                EXIT bin_loop_work
    2540. 

  2540.             END IF
    2541. 

  2541.          END DO cat_loop_work
    2542. 

  2542.       END DO bin_loop_work
    2543. 

  2543. 

  2544.       !  So the big question is, did the aggregation change the bin?  If the aggregation does not change the resulting
    2545. 

  2545.       !  bin, then we leave everything alone.  However, if there would be a change in the eventual bin chosen by
    2546. 

  2546.       !  the simple dominant-category method, then we become pro-active interventionists and rectify this heinous
    2547. 

  2547.       !  injustice foisted upon the lowly flora.
    2548. 

  2548. 

  2549.       IF ( bin_work .EQ. bin_orig ) THEN
    2550. 

  2550.          !  No op, we do nothing.
    2551. 

  2551.       ELSE
    2552. 

  2552.          DO ic = 1 , max_cats_per_bin
    2553. 

  2553.             landuse_frac(cats_in_bin(ic,bin_work)) = landuse_frac_work(cats_in_bin(ic,bin_work))
    2554. 

  2554.          END DO
    2555. 

  2555.       END IF
    2556. 

  2556.             
    2557. 

  2557.    END SUBROUTINE aggregate_categories_part2
    2558. 

  2558. 

  2559. END MODULE module_soil_pre
    2560. 

  2560. 

  2561. FUNCTION skip_middle_points_t ( ids , ide , jds , jde , &
    2562. 

  2562.                                 i_in , j_in , width ,   &
    2563. 

  2563.                                 subtleties_exist )      &
    2564. 

  2564.                        RESULT ( skip_it )
    2565. 

  2565.  
    2566. 

  2566.    IMPLICIT NONE
    2567. 

  2567. 

  2568.    INTEGER , INTENT(IN) :: ids , ide , jds , jde
    2569. 

  2569.    INTEGER , INTENT(IN) :: i_in , j_in , width
    2570. 

  2570.    LOGICAL , INTENT(IN) :: subtleties_exist
    2571. 

  2571.    
    2572. 

  2572.    LOGICAL              :: skip_it
    2573. 

  2573. 

  2574.    INTEGER , PARAMETER :: slop = 0
    2575. 

  2575. 

  2576.    IF ( ( subtleties_exist ) .OR. ( ide .EQ. 3 ) .OR. ( jde .EQ. 3 ) ) THEN
    2577. 

  2577.       skip_it = .FALSE.
    2578. 

  2578.    ELSE
    2579. 

  2579.       IF ( ( i_in .GE. ids+width+slop ) .AND. ( i_in .LE. ide-1-width-slop )   .AND. &
    2580. 

  2580.            ( j_in .GE. jds+width+slop ) .AND. ( j_in .LE. jde-1-width-slop ) ) THEN
    2581. 

  2581.          skip_it = .TRUE.
    2582. 

  2582.       ELSE
    2583. 

  2583.          skip_it = .FALSE.
    2584. 

  2584.       END IF
    2585. 

  2585.    END IF
    2586. 

  2586. 

  2587. END FUNCTION skip_middle_points_t
    2588. 

  2588. 

  2589. #else
    2590. 

  2590. 

  2591. MODULE module_soil_pre
    2592. 

  2592. 

  2593.    USE module_date_time
    2594. 

  2594.    USE module_state_description
    2595. 

  2595. 

  2596. CONTAINS
    2597. 

  2597. 

  2598.    SUBROUTINE adjust_for_seaice_pre ( xice , landmask , tsk , ivgtyp , vegcat , lu_index , &
    2599. 

  2599.                                       xland , landusef , isltyp , soilcat , soilctop , &
    2600. 

  2600.                                       soilcbot , tmn , &
    2601. 

  2601.                                       seaice_threshold , &
    2602. 

  2602.                                       fractional_seaice, &
    2603. 

  2603.                                       num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
    2604. 

  2604.                                       iswater , isice , &
    2605. 

  2605.                                       scheme , &
    2606. 

  2606.                                       ids , ide , jds , jde , kds , kde , &
    2607. 

  2607.                                       ims , ime , jms , jme , kms , kme , &
    2608. 

  2608.                                       its , ite , jts , jte , kts , kte )
    2609. 

  2609. 

  2610.       IMPLICIT NONE
    2611. 

  2611. 

  2612.       INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
    2613. 

  2613.                               ims , ime , jms , jme , kms , kme , &
    2614. 

  2614.                               its , ite , jts , jte , kts , kte , &
    2615. 

  2615.                               iswater , isice
    2616. 

  2616.       INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat , scheme
    2617. 

  2617. 

  2618.       REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landusef
    2619. 

  2619.       REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(INOUT):: soilctop
    2620. 

  2620.       REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(INOUT):: soilcbot
    2621. 

  2621.       INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp
    2622. 

  2622.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask , xice , tsk , lu_index , &
    2623. 

  2623.                                                            vegcat, xland , soilcat , tmn
    2624. 

  2624.       REAL , INTENT(IN) :: seaice_threshold
    2625. 

  2625. 

  2626.       INTEGER :: i , j , num_seaice_changes , loop
    2627. 

  2627.       CHARACTER (LEN=132) :: message
    2628. 

  2628. 

  2629. 

  2630.       integer, intent(in) :: fractional_seaice
    2631. 

  2631.       real                :: xice_threshold
    2632. 

  2632. 

  2633.       IF ( FRACTIONAL_SEAICE == 0 ) THEN
    2634. 

  2634.          xice_threshold = 0.5
    2635. 

  2635.       ELSEIF ( FRACTIONAL_SEAICE == 1 ) THEN
    2636. 

  2636.          CALL WRF_ERROR_FATAL("NMM cannot use FRACTIONAL_SEAICE = 1")
    2637. 

  2637.          xice_threshold = 0.02
    2638. 

  2638.       ENDIF
    2639. 

  2639. 

  2640.       fix_seaice : SELECT CASE ( scheme )
    2641. 

  2641. 

  2642.          CASE ( SLABSCHEME )
    2643. 

  2643.             DO j = jts , MIN(jde-1,jte)
    2644. 

  2644.                DO i = its , MIN(ide-1,ite)
    2645. 

  2645.                   IF ( xice(i,j) .GT. 200.0 ) THEN
    2646. 

  2646.                      xice(i,j) = 0.
    2647. 

  2647.                      num_seaice_changes = num_seaice_changes + 1
    2648. 

  2648.                   END IF
    2649. 

  2649.                END DO
    2650. 

  2650.             END DO
    2651. 

  2651.             IF ( num_seaice_changes .GT. 0 ) THEN
    2652. 

  2652.                WRITE ( message , FMT='(A,I6)' ) &
    2653. 

  2653.                'Total pre number of sea ice locations removed (due to FLAG values) = ', &
    2654. 

  2654.                num_seaice_changes
    2655. 

  2655.                CALL wrf_debug ( 0 , message )
    2656. 

  2656.             END IF
    2657. 

  2657.             num_seaice_changes = 0
    2658. 

  2658.             DO j = jts , MIN(jde-1,jte)
    2659. 

  2659.                DO i = its , MIN(ide-1,ite)
    2660. 

  2660.                   IF ( ( xice(i,j) .GE. xice_threshold ) .OR. &
    2661. 

  2661.                        ( ( landmask(i,j) .LT. 0.5 ) .AND. ( tsk(i,j) .LT. seaice_threshold ) ) ) THEN
    2662. 

  2662.                      IF ( FRACTIONAL_SEAICE == 0 ) THEN
    2663. 

  2663.                         xice(i,j) = 1.0
    2664. 

  2664.                      ENDIF
    2665. 

  2665.                      num_seaice_changes = num_seaice_changes + 1
    2666. 

  2666.                      tmn(i,j) = 271.4
    2667. 

  2667.                      vegcat(i,j)=isice
    2668. 

  2668.                      lu_index(i,j)=ivgtyp(i,j)
    2669. 

  2669.                      landmask(i,j)=1.
    2670. 

  2670.                      xland(i,j)=1.
    2671. 

  2671.                      DO loop=1,num_veg_cat
    2672. 

  2672.                         landusef(i,loop,j)=0.
    2673. 

  2673.                      END DO
    2674. 

  2674.                      landusef(i,ivgtyp(i,j),j)=1.
    2675. 

  2675. 

  2676.                      isltyp(i,j) = 16
    2677. 

  2677.                      soilcat(i,j)=isltyp(i,j)
    2678. 

  2678.                      DO loop=1,num_soil_top_cat
    2679. 

  2679.                         soilctop(i,loop,j)=0
    2680. 

  2680.                      END DO
    2681. 

  2681.                      DO loop=1,num_soil_bot_cat
    2682. 

  2682.                         soilcbot(i,loop,j)=0
    2683. 

  2683.                      END DO
    2684. 

  2684.                      soilctop(i,isltyp(i,j),j)=1.
    2685. 

  2685.                      soilcbot(i,isltyp(i,j),j)=1.
    2686. 

  2686.                   ELSE
    2687. 

  2687.                      xice(i,j) = 0.0
    2688. 

  2688.                   END IF
    2689. 

  2689.                END DO
    2690. 

  2690.             END DO
    2691. 

  2691.             IF ( num_seaice_changes .GT. 0 ) THEN
    2692. 

  2692.                WRITE ( message , FMT='(A,I6)' ) &
    2693. 

  2693.                'Total pre number of sea ice location changes (water to land) = ', num_seaice_changes
    2694. 

  2694.                CALL wrf_debug ( 0 , message )
    2695. 

  2695.             END IF
    2696. 

  2696. 

  2697.          CASE ( LSMSCHEME )
    2698. 

  2698.          CASE ( RUCLSMSCHEME )
    2699. 

  2699. 

  2700.       END SELECT fix_seaice
    2701. 

  2701. 

  2702.    END SUBROUTINE adjust_for_seaice_pre
    2703. 

  2703. 

  2704.    SUBROUTINE adjust_for_seaice_post ( xice , landmask , tsk , ivgtyp , vegcat , lu_index , &
    2705. 

  2705.                                       xland , landusef , isltyp , soilcat , soilctop , &
    2706. 

  2706.                                       soilcbot , tmn , &
    2707. 

  2707.                                       tslb , smois , sh2o , &
    2708. 

  2708.                                       seaice_threshold , &
    2709. 

  2709.                                       fractional_seaice, &
    2710. 

  2710.                                       num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
    2711. 

  2711.                                       num_soil_layers , &
    2712. 

  2712.                                       iswater , isice , &
    2713. 

  2713.                                       scheme , &
    2714. 

  2714.                                       ids , ide , jds , jde , kds , kde , &
    2715. 

  2715.                                       ims , ime , jms , jme , kms , kme , &
    2716. 

  2716.                                       its , ite , jts , jte , kts , kte )
    2717. 

  2717. 

  2718.       IMPLICIT NONE
    2719. 

  2719. 

  2720.       INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
    2721. 

  2721.                               ims , ime , jms , jme , kms , kme , &
    2722. 

  2722.                               its , ite , jts , jte , kts , kte , &
    2723. 

  2723.                               iswater , isice
    2724. 

  2724.       INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat , scheme
    2725. 

  2725.       INTEGER , INTENT(IN) :: num_soil_layers
    2726. 

  2726. 

  2727.       REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landusef
    2728. 

  2728.       REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(INOUT):: soilctop
    2729. 

  2729.       REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(INOUT):: soilcbot
    2730. 

  2730.       REAL , DIMENSION(ims:ime,1:num_soil_layers,jms:jme) , INTENT(INOUT):: tslb , smois , sh2o
    2731. 

  2731.       INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp
    2732. 

  2732.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask , xice , tsk , lu_index , &
    2733. 

  2733.                                                            vegcat, xland , soilcat , tmn
    2734. 

  2734.       REAL , INTENT(IN) :: seaice_threshold
    2735. 

  2735.       REAL :: total_depth , mid_point_depth
    2736. 

  2736. 

  2737.       INTEGER :: i , j , num_seaice_changes , loop
    2738. 

  2738.       CHARACTER (LEN=132) :: message
    2739. 

  2739. 

  2740.       integer, intent(in) :: fractional_seaice
    2741. 

  2741.       real                :: xice_threshold
    2742. 

  2742.       IF ( FRACTIONAL_SEAICE == 0 ) THEN
    2743. 

  2743.          xice_threshold = 0.5
    2744. 

  2744.       ELSEIF ( FRACTIONAL_SEAICE == 1 ) THEN
    2745. 

  2745.          CALL WRF_ERROR_FATAL("NMM cannot use FRACTIONAL_SEAICE = 1")
    2746. 

  2746.          xice_threshold = 0.02
    2747. 

  2747.       ENDIF
    2748. 

  2748.       fix_seaice : SELECT CASE ( scheme )
    2749. 

  2749. 

  2750.          CASE ( SLABSCHEME )
    2751. 

  2751. 

  2752. !SBAO
    2753. 

  2753.          CASE ( LSMSCHEME, GFDLSLAB )
    2754. 

  2754.             DO j = jts , MIN(jde-1,jte)
    2755. 

  2755.                DO i = its , MIN(ide-1,ite)
    2756. 

  2756.                   IF ( xice(i,j) .GT. 200.0 ) THEN
    2757. 

  2757.                      xice(i,j) = 0.
    2758. 

  2758.                      num_seaice_changes = num_seaice_changes + 1
    2759. 

  2759.                   END IF
    2760. 

  2760.                END DO
    2761. 

  2761.             END DO
    2762. 

  2762.             IF ( num_seaice_changes .GT. 0 ) THEN
    2763. 

  2763.                WRITE ( message , FMT='(A,I6)' ) &
    2764. 

  2764.                'Total post number of sea ice locations removed (due to FLAG values) = ', &
    2765. 

  2765.                num_seaice_changes
    2766. 

  2766.                CALL wrf_debug ( 0 , message )
    2767. 

  2767.             END IF
    2768. 

  2768.             num_seaice_changes = 0
    2769. 

  2769.             DO j = jts , MIN(jde-1,jte)
    2770. 

  2770.                DO i = its , MIN(ide-1,ite)
    2771. 

  2771.                   IF ( ( xice(i,j) .GE. xice_threshold ) .OR. &
    2772. 

  2772.                        ( ( landmask(i,j) .LT. 0.5 ) .AND. ( tsk(i,j) .LT. seaice_threshold ) ) ) THEN
    2773. 

  2773.                      IF ( FRACTIONAL_SEAICE == 0 ) THEN
    2774. 

  2774.                         xice(i,j) = 1.0
    2775. 

  2775.                      ENDIF
    2776. 

  2776.                      num_seaice_changes = num_seaice_changes + 1
    2777. 

  2777.                      tmn(i,j) = 271.16
    2778. 

  2778.                      vegcat(i,j)=isice
    2779. 

  2779.                      lu_index(i,j)=ivgtyp(i,j)
    2780. 

  2780.                      landmask(i,j)=1.
    2781. 

  2781.                      xland(i,j)=1.
    2782. 

  2782.                      DO loop=1,num_veg_cat
    2783. 

  2783.                         landusef(i,loop,j)=0.
    2784. 

  2784.                      END DO
    2785. 

  2785.                      landusef(i,ivgtyp(i,j),j)=1.
    2786. 

  2786. 

  2787.                      isltyp(i,j) = 16
    2788. 

  2788.                      soilcat(i,j)=isltyp(i,j)
    2789. 

  2789.                      DO loop=1,num_soil_top_cat
    2790. 

  2790.                         soilctop(i,loop,j)=0
    2791. 

  2791.                      END DO
    2792. 

  2792.                      DO loop=1,num_soil_bot_cat
    2793. 

  2793.                         soilcbot(i,loop,j)=0
    2794. 

  2794.                      END DO
    2795. 

  2795.                      soilctop(i,isltyp(i,j),j)=1.
    2796. 

  2796.                      soilcbot(i,isltyp(i,j),j)=1.
    2797. 

  2797. 

  2798.                      total_depth = 3. ! ice is 3 m deep, num_soil_layers equispaced layers
    2799. 

  2799.                      DO loop = 1,num_soil_layers
    2800. 

  2800.                         mid_point_depth=(total_depth/num_soil_layers)/2. + &
    2801. 

  2801.                                         (loop-1)*(total_depth/num_soil_layers)
    2802. 

  2802.                         tslb(i,loop,j) = ( (total_depth-mid_point_depth)*tsk(i,j) + &
    2803. 

  2803.                                             mid_point_depth*tmn(i,j) ) / total_depth
    2804. 

  2804.                      END DO
    2805. 

  2805. 

  2806.                      DO loop=1,num_soil_layers
    2807. 

  2807.                         smois(i,loop,j) = 1.0
    2808. 

  2808.                         sh2o(i,loop,j)  = 0.0
    2809. 

  2809.                      END DO
    2810. 

  2810.                   ELSE
    2811. 

  2811.                      xice(i,j) = 0.0
    2812. 

  2812.                   END IF
    2813. 

  2813.                END DO
    2814. 

  2814.             END DO
    2815. 

  2815.             IF ( num_seaice_changes .GT. 0 ) THEN
    2816. 

  2816.                WRITE ( message , FMT='(A,I6)' ) &
    2817. 

  2817.                'Total post number of sea ice location changes (water to land) = ', num_seaice_changes
    2818. 

  2818.                CALL wrf_debug ( 0 , message )
    2819. 

  2819.             END IF
    2820. 

  2820. 

  2821.          CASE ( RUCLSMSCHEME )
    2822. 

  2822.             DO j = jts , MIN(jde-1,jte)
    2823. 

  2823.                DO i = its , MIN(ide-1,ite)
    2824. 

  2824.                   IF ( xice(i,j) .GT. 200.0 ) THEN
    2825. 

  2825.                      xice(i,j) = 0.
    2826. 

  2826.                      num_seaice_changes = num_seaice_changes + 1
    2827. 

  2827.                   END IF
    2828. 

  2828.                END DO
    2829. 

  2829.             END DO
    2830. 

  2830.             IF ( num_seaice_changes .GT. 0 ) THEN
    2831. 

  2831.                WRITE ( message , FMT='(A,I6)' ) &
    2832. 

  2832.                'Total post number of sea ice locations removed (due to FLAG values) = ', &
    2833. 

  2833.                num_seaice_changes
    2834. 

  2834.                CALL wrf_debug ( 0 , message )
    2835. 

  2835.             END IF
    2836. 

  2836.             num_seaice_changes = 0
    2837. 

  2837.             DO j = jts , MIN(jde-1,jte)
    2838. 

  2838.                DO i = its , MIN(ide-1,ite)
    2839. 

  2839.                   IF ( ( xice(i,j) .GE. xice_threshold ) .OR. &
    2840. 

  2840.                        ( ( landmask(i,j) .LT. 0.5 ) .AND. ( tsk(i,j) .LT. seaice_threshold ) ) ) THEN 
    2841. 

  2841. 

  2842.                      IF ( FRACTIONAL_SEAICE == 0 ) THEN
    2843. 

  2843.                         xice(i,j) = 1.0
    2844. 

  2844.                      ELSE
    2845. 

  2845.                         xice(i,j)=max(0.25,xice(i,j))
    2846. 

  2846.                      ENDIF
    2847. 

  2847.                      num_seaice_changes = num_seaice_changes + 1
    2848. 

  2848.                      if(landmask(i,j) .LT. 0.5 )tmn(i,j) = 271.4
    2849. 

  2849.                      vegcat(i,j)=isice
    2850. 

  2850.                      ivgtyp(i,j)=isice
    2851. 

  2851.                      lu_index(i,j)=isice
    2852. 

  2852.                      landmask(i,j)=1.
    2853. 

  2853.                      xland(i,j)=1.
    2854. 

  2854.                      DO loop=1,num_veg_cat
    2855. 

  2855.                         landusef(i,loop,j)=0.
    2856. 

  2856.                      END DO
    2857. 

  2857.                      landusef(i,ivgtyp(i,j),j)=1.
    2858. 

  2858. 

  2859.                      isltyp(i,j) = 16
    2860. 

  2860.                      soilcat(i,j)=isltyp(i,j)
    2861. 

  2861.                      DO loop=1,num_soil_top_cat
    2862. 

  2862.                         soilctop(i,loop,j)=0
    2863. 

  2863.                      END DO
    2864. 

  2864.                      DO loop=1,num_soil_bot_cat
    2865. 

  2865.                         soilcbot(i,loop,j)=0
    2866. 

  2866.                      END DO
    2867. 

  2867.                      soilctop(i,isltyp(i,j),j)=1.
    2868. 

  2868.                      soilcbot(i,isltyp(i,j),j)=1.
    2869. 

  2869. 

  2870.                  total_depth = 3. ! ice is 3 m deep, num_soil_layers equispaced layers
    2871. 

  2871.                        tslb(i,1,j) = tsk(i,j)
    2872. 

  2872.                        tslb(i,num_soil_layers,j) = tmn(i,j)
    2873. 

  2873.                      DO loop = 2,num_soil_layers-1
    2874. 

  2874.                         mid_point_depth=(total_depth/num_soil_layers)/4. + &
    2875. 

  2875.                                         (loop-2)*(total_depth/num_soil_layers)
    2876. 

  2876.                         tslb(i,loop,j) = ( (total_depth-mid_point_depth)*tsk(i,j) + &
    2877. 

  2877.                                             mid_point_depth*tmn(i,j) ) / total_depth
    2878. 

  2878.                      END DO
    2879. 

  2879. 

  2880.                      DO loop=1,num_soil_layers
    2881. 

  2881.                         smois(i,loop,j) = 1.0
    2882. 

  2882.                         sh2o(i,loop,j)  = 0.0
    2883. 

  2883.                      END DO
    2884. 

  2884.                   ELSE IF ( xice(i,j) .LT. xice_threshold ) THEN
    2885. 

  2885.                      xice(i,j) = 0.
    2886. 

  2886.                   END IF
    2887. 

  2887.                END DO
    2888. 

  2888.             END DO
    2889. 

  2889.             IF ( num_seaice_changes .GT. 0 ) THEN
    2890. 

  2890.                WRITE ( message , FMT='(A,I6)' ) &
    2891. 

  2891.                'Total post number of sea ice location changes (water to land) = ', num_seaice_changes
    2892. 

  2892.                CALL wrf_debug ( 0 , message )
    2893. 

  2893.             END IF
    2894. 

  2894. 

  2895.       END SELECT fix_seaice
    2896. 

  2896. 

  2897.    END SUBROUTINE adjust_for_seaice_post
    2898. 

  2898. 

  2899.    SUBROUTINE process_percent_cat_new ( landmask ,  &
    2900. 

  2900.                                 landuse_frac , soil_top_cat , soil_bot_cat , &
    2901. 

  2901.                                 isltyp , ivgtyp , &
    2902. 

  2902.                                 num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
    2903. 

  2903.                                 ids , ide , jds , jde , kds , kde , &
    2904. 

  2904.                                 ims , ime , jms , jme , kms , kme , &
    2905. 

  2905.                                 its , ite , jts , jte , kts , kte , &
    2906. 

  2906.                                 iswater )
    2907. 

  2907. 

  2908.       IMPLICIT NONE
    2909. 

  2909. 

  2910.       INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
    2911. 

  2911.                               ims , ime , jms , jme , kms , kme , &
    2912. 

  2912.                               its , ite , jts , jte , kts , kte , &
    2913. 

  2913.                               iswater
    2914. 

  2914.       INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
    2915. 

  2915.       REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landuse_frac
    2916. 

  2916.       REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(IN):: soil_top_cat
    2917. 

  2917.       REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(IN):: soil_bot_cat
    2918. 

  2918.       INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp
    2919. 

  2919.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask
    2920. 

  2920. 

  2921.       INTEGER :: i , j , l , ll, dominant_index
    2922. 

  2922.       REAL :: dominant_value
    2923. 

  2923. 

  2924. #ifdef WRF_CHEM
    2925. 

  2925. !      REAL :: lwthresh = .99
    2926. 

  2926.       REAL :: lwthresh = .50
    2927. 

  2927. #else
    2928. 

  2928.       REAL :: lwthresh = .50
    2929. 

  2929. #endif
    2930. 

  2930. 

  2931.       INTEGER , PARAMETER :: iswater_soil = 14
    2932. 

  2932.       INTEGER :: iforce
    2933. 

  2933.       CHARACTER (LEN=1024) :: message
    2934. 

  2934. 

  2935.       !  Sanity check on the 50/50 points
    2936. 

  2936. 

  2937.       DO j = jts , MIN(jde-1,jte)
    2938. 

  2938.          DO i = its , MIN(ide-1,ite)
    2939. 

  2939.             dominant_value = landuse_frac(i,iswater,j)
    2940. 

  2940.             IF ( dominant_value .EQ. lwthresh ) THEN
    2941. 

  2941.                DO l = 1 , num_veg_cat
    2942. 

  2942.                   IF ( l .EQ. iswater ) CYCLE
    2943. 

  2943.                   IF ( landuse_frac(i,l,j) .EQ. lwthresh ) THEN
    2944. 

  2944.                 write(message, FMT='(I4,I4,A,I4,A,F12.4)') i,j,' water and category ',l,' both at 50%, landmask is ',landmask(i,j)
    2945. 

  2945.                 call wrf_message ( message )
    2946. 

  2946.                      landuse_frac(i,l,j) = lwthresh - .01
    2947. 

  2947.                      landuse_frac(i,iswater,j) = 1. - (lwthresh + 0.01)
    2948. 

  2948.                   END IF
    2949. 

  2949.                END DO
    2950. 

  2950.             END IF
    2951. 

  2951.          END DO
    2952. 

  2952.       END DO
    2953. 

  2953. 

  2954.       !  Compute the dominant VEGETATION INDEX.
    2955. 

  2955. 

  2956.       DO j = jts , MIN(jde-1,jte)
    2957. 

  2957.          DO i = its , MIN(ide-1,ite)
    2958. 

  2958.             dominant_value = landuse_frac(i,1,j)
    2959. 

  2959.             dominant_index = 1
    2960. 

  2960.             DO l = 2 , num_veg_cat
    2961. 

  2961.                IF        ( l .EQ. iswater ) THEN
    2962. 

  2962.                   ! wait a bit
    2963. 

  2963.                ELSE IF ( ( l .NE. iswater ) .AND. ( landuse_frac(i,l,j) .GT. dominant_value ) ) THEN
    2964. 

  2964.                   dominant_value = landuse_frac(i,l,j)
    2965. 

  2965.                   dominant_index = l
    2966. 

  2966.                END IF
    2967. 

  2967.             END DO
    2968. 

  2968.             IF ( landuse_frac(i,iswater,j) .GT. lwthresh ) THEN
    2969. 

  2969.                dominant_value = landuse_frac(i,iswater,j)
    2970. 

  2970.                dominant_index = iswater
    2971. 

  2971. #if 0
    2972. 

  2972. si needs to beef up consistency checks before we can use this part
    2973. 

  2973.             ELSE IF ( ( landuse_frac(i,iswater,j) .EQ. lwthresh) .AND. &
    2974. 

  2974.                       ( dominant_value .EQ. lwthresh) ) THEN
    2975. 

  2975.                ! no op
    2976. 

  2976. #else
    2977. 

  2977. ELSEIF((landuse_frac(i,iswater,j).EQ.lwthresh).AND.(dominant_value.EQ.lwthresh).and.(dominant_index.LT.iswater))THEN
    2978. 

  2978. write(message,*)'temporary SI landmask fix'
    2979. 

  2979. call wrf_message(trim(message))
    2980. 

  2980. ! no op
    2981. 

  2981. ELSEIF((landuse_frac(i,iswater,j).EQ.lwthresh).AND.(dominant_value.EQ.lwthresh).and.(dominant_index.GT.iswater))THEN
    2982. 

  2982. write(message,*)'temporary SI landmask fix'
    2983. 

  2983. call wrf_message(trim(message))
    2984. 

  2984. dominant_value = landuse_frac(i,iswater,j)
    2985. 

  2985. dominant_index = iswater
    2986. 

  2986. #endif
    2987. 

  2987.             ELSE IF ( ( landuse_frac(i,iswater,j) .EQ. lwthresh ) .AND. &
    2988. 

  2988.                       ( dominant_value .LT. lwthresh ) ) THEN
    2989. 

  2989.                dominant_value = landuse_frac(i,iswater,j)
    2990. 

  2990.                dominant_index = iswater
    2991. 

  2991.             END IF
    2992. 

  2992.             IF      ( dominant_index .EQ. iswater ) THEN
    2993. 

  2993. if(landmask(i,j).gt.lwthresh) then
    2994. 

  2994. write(message,*) 'changing to water at point ',i,j
    2995. 

  2995. call wrf_message(trim(message))
    2996. 

  2996. write(message,*)  nint(landuse_frac(i,:,j)*100)
    2997. 

  2997. call wrf_message(trim(message))
    2998. 

  2998. endif
    2999. 

  2999.                landmask(i,j) = 0
    3000. 

  3000.             ELSE IF ( dominant_index .NE. iswater ) THEN
    3001. 

  3001. if(landmask(i,j).lt.lwthresh) then
    3002. 

  3002. write(message,*) 'changing to land at point ',i,j
    3003. 

  3003. call wrf_message(trim(message))
    3004. 

  3004. write(message,*) nint(landuse_frac(i,:,j)*100)
    3005. 

  3005. call wrf_message(trim(message))
    3006. 

  3006. endif
    3007. 

  3007.                landmask(i,j) = 1
    3008. 

  3008.             END IF
    3009. 

  3009.             ivgtyp(i,j) = dominant_index
    3010. 

  3010.          END DO
    3011. 

  3011.       END DO
    3012. 

  3012. 

  3013.       !  Compute the dominant SOIL TEXTURE INDEX, TOP.
    3014. 

  3014. 

  3015.       iforce = 0
    3016. 

  3016.       DO i = its , MIN(ide-1,ite)
    3017. 

  3017.          DO j = jts , MIN(jde-1,jte)
    3018. 

  3018.             dominant_value = soil_top_cat(i,1,j)
    3019. 

  3019.             dominant_index = 1
    3020. 

  3020.             IF ( landmask(i,j) .GT. lwthresh ) THEN
    3021. 

  3021.                DO l = 2 , num_soil_top_cat
    3022. 

  3022.                   IF ( ( l .NE. iswater_soil ) .AND. ( soil_top_cat(i,l,j) .GT. dominant_value ) ) THEN
    3023. 

  3023.                      dominant_value = soil_top_cat(i,l,j)
    3024. 

  3024.                      dominant_index = l
    3025. 

  3025.                   END IF
    3026. 

  3026.                END DO
    3027. 

  3027.                IF ( dominant_value .LT. 0.01 ) THEN
    3028. 

  3028.                   iforce = iforce + 1
    3029. 

  3029.                   WRITE ( message , FMT = '(A,I4,I4)' ) &
    3030. 

  3030.                   'based on landuse, changing soil to land at point ',i,j
    3031. 

  3031.                   CALL wrf_debug(1,message)
    3032. 

  3032. !atec             WRITE ( message , FMT = '(16(i3,1x))' ) &
    3033. 

  3033. !atec             1, 2, 3, 4, 5, 6, 7, 8, 9, 10,11,12, 13, 14, 15, 16
    3034. 

  3034. !atec             CALL wrf_debug(1,message)
    3035. 

  3035. !atec             WRITE ( message , FMT = '(16(i3,1x))' ) &
    3036. 

  3036. !atec             nint(soil_top_cat(i,:,j)*100)
    3037. 

  3037. !atec             CALL wrf_debug(1,message)
    3038. 

  3038.                   dominant_index = 8
    3039. 

  3039.                END IF
    3040. 

  3040.             ELSE
    3041. 

  3041.                dominant_index = iswater_soil
    3042. 

  3042.             END IF
    3043. 

  3043.             isltyp(i,j) = dominant_index
    3044. 

  3044.          END DO
    3045. 

  3045.       END DO
    3046. 

  3046. 

  3047. if(iforce.ne.0)then
    3048. 

  3048. WRITE(message,FMT='(A,I4,A,I6)' ) &
    3049. 

  3049. 'forcing artificial silty clay loam at ',iforce,' points, out of ',&
    3050. 

  3050. (MIN(ide-1,ite)-its+1)*(MIN(jde-1,jte)-jts+1)
    3051. 

  3051. CALL wrf_debug(0,message)
    3052. 

  3052. endif
    3053. 

  3053. 

  3054.    END SUBROUTINE process_percent_cat_new
    3055. 

  3055. 

  3056.    SUBROUTINE process_soil_real ( tsk , tmn , &
    3057. 

  3057.                                 landmask , sst , &
    3058. 

  3058.                                 st_input , sm_input , sw_input , st_levels_input , sm_levels_input , sw_levels_input , &
    3059. 

  3059.                                 zs , dzs , tslb , smois , sh2o , &
    3060. 

  3060.                                 flag_sst , flag_soilt000, flag_soilm000, &
    3061. 

  3061.                                 ids , ide , jds , jde , kds , kde , &
    3062. 

  3062.                                 ims , ime , jms , jme , kms , kme , &
    3063. 

  3063.                                 its , ite , jts , jte , kts , kte , &
    3064. 

  3064.                                 sf_surface_physics , num_soil_layers , real_data_init_type , &
    3065. 

  3065.                                 num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
    3066. 

  3066.                                 num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc )
    3067. 

  3067. 

  3068.       IMPLICIT NONE
    3069. 

  3069. 

  3070.       INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
    3071. 

  3071.                               ims , ime , jms , jme , kms , kme , &
    3072. 

  3072.                               its , ite , jts , jte , kts , kte , &
    3073. 

  3073.                               sf_surface_physics , num_soil_layers , real_data_init_type , &
    3074. 

  3074.                               num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
    3075. 

  3075.                               num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc
    3076. 

  3076. 

  3077.       INTEGER , INTENT(IN) :: flag_sst, flag_soilt000, flag_soilm000
    3078. 

  3078. 

  3079.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst
    3080. 

  3080. 

  3081.       INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input
    3082. 

  3082.       INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input
    3083. 

  3083.       INTEGER , DIMENSION(1:num_sw_levels_input) , INTENT(INOUT) :: sw_levels_input
    3084. 

  3084.       REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input
    3085. 

  3085.       REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input
    3086. 

  3086.       REAL , DIMENSION(ims:ime,1:num_sw_levels_alloc,jms:jme) , INTENT(INOUT) :: sw_input
    3087. 

  3087. 

  3088.       REAL, DIMENSION(1:num_soil_layers), INTENT(OUT)  ::  zs,dzs
    3089. 

  3089.       REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois , sh2o
    3090. 

  3090.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn
    3091. 

  3091.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk
    3092. 

  3092. 

  3093.       INTEGER :: i , j , l , dominant_index , num_soil_cat , num_veg_cat
    3094. 

  3094.       REAL :: dominant_value
    3095. 

  3095. 

  3096.       !  Initialize the soil depth, and the soil temperature and moisture.
    3097. 

  3097. 

  3098.       IF      ( ( sf_surface_physics .EQ. SLABSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    3099. 

  3099.          CALL init_soil_depth_1 ( zs , dzs , num_soil_layers )
    3100. 

  3100.          CALL init_soil_1_real ( tsk , tmn , tslb , zs , dzs , num_soil_layers , real_data_init_type , &
    3101. 

  3101.                                  landmask , sst , flag_sst , &
    3102. 

  3102.                                  ids , ide , jds , jde , kds , kde , &
    3103. 

  3103.                                  ims , ime , jms , jme , kms , kme , &
    3104. 

  3104.                                  its , ite , jts , jte , kts , kte )
    3105. 

  3105. 

  3106.       ELSE IF ( ( sf_surface_physics .EQ. LSMSCHEME .or. sf_surface_physics .eq. 88 ) .AND. &
    3107. 

  3107.                 ( num_soil_layers .GT. 1 ) ) THEN
    3108. 

  3108.          CALL init_soil_depth_2 ( zs , dzs , num_soil_layers )
    3109. 

  3109.          CALL init_soil_2_real ( tsk , tmn , smois , sh2o , tslb , &
    3110. 

  3110.                                  st_input , sm_input , sw_input , landmask , sst , &
    3111. 

  3111.                                  zs , dzs , &
    3112. 

  3112.                                  st_levels_input , sm_levels_input , sw_levels_input , &
    3113. 

  3113.                                  num_soil_layers , num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
    3114. 

  3114.                                  num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , &
    3115. 

  3115.                                  flag_sst , flag_soilt000 , flag_soilm000 , &
    3116. 

  3116.                                  ids , ide , jds , jde , kds , kde , &
    3117. 

  3117.                                  ims , ime , jms , jme , kms , kme , &
    3118. 

  3118.                                  its , ite , jts , jte , kts , kte )
    3119. 

  3119. !        CALL init_soil_old ( tsk , tmn , &
    3120. 

  3120. !                             smois , tslb , zs , dzs , num_soil_layers , &
    3121. 

  3121. !                             st000010_input , st010040_input , st040100_input , st100200_input , &
    3122. 

  3122. !                             st010200_input , &
    3123. 

  3123. !                             sm000010_input , sm010040_input , sm040100_input , sm100200_input , &
    3124. 

  3124. !                             sm010200_input , &
    3125. 

  3125. !                             landmask_input , sst_input , &
    3126. 

  3126. !                             ids , ide , jds , jde , kds , kde , &
    3127. 

  3127. !                             ims , ime , jms , jme , kms , kme , &
    3128. 

  3128. !                             its , ite , jts , jte , kts , kte )
    3129. 

  3129.       ELSE IF ( ( sf_surface_physics .EQ. NOAHMPSCHEME .or. sf_surface_physics .eq. 88 ) .AND. &
    3130. 

  3130.                 ( num_soil_layers .GT. 1 ) ) THEN
    3131. 

  3131.          CALL init_soil_depth_2 ( zs , dzs , num_soil_layers )
    3132. 

  3132.          CALL init_soil_2_real ( tsk , tmn , smois , sh2o , tslb , &
    3133. 

  3133.                                  st_input , sm_input , sw_input , landmask , sst , &
    3134. 

  3134.                                  zs , dzs , &
    3135. 

  3135.                                  st_levels_input , sm_levels_input , sw_levels_input , &
    3136. 

  3136.                                  num_soil_layers , num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
    3137. 

  3137.                                  num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , &
    3138. 

  3138.                                  flag_sst , flag_soilt000 , flag_soilm000 , &
    3139. 

  3139.                                  ids , ide , jds , jde , kds , kde , &
    3140. 

  3140.                                  ims , ime , jms , jme , kms , kme , &
    3141. 

  3141.                                  its , ite , jts , jte , kts , kte )
    3142. 

  3142. !        CALL init_soil_old ( tsk , tmn , &
    3143. 

  3143. !                             smois , tslb , zs , dzs , num_soil_layers , &
    3144. 

  3144. !                             st000010_input , st010040_input , st040100_input , st100200_input , &
    3145. 

  3145. !                             st010200_input , &
    3146. 

  3146. !                             sm000010_input , sm010040_input , sm040100_input , sm100200_input , &
    3147. 

  3147. !                             sm010200_input , &
    3148. 

  3148. !                             landmask_input , sst_input , &
    3149. 

  3149. !                             ids , ide , jds , jde , kds , kde , &
    3150. 

  3150. !                             ims , ime , jms , jme , kms , kme , &
    3151. 

  3151. !                             its , ite , jts , jte , kts , kte )
    3152. 

  3152.       ELSE IF ( ( sf_surface_physics .EQ. RUCLSMSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    3153. 

  3153.          CALL init_soil_depth_3 ( zs , dzs , num_soil_layers )
    3154. 

  3154.          CALL init_soil_3_real ( tsk , tmn , smois , tslb , &
    3155. 

  3155.                                  st_input , sm_input , landmask , sst , &
    3156. 

  3156.                                  zs , dzs , &
    3157. 

  3157.                                  st_levels_input , sm_levels_input , &
    3158. 

  3158.                                  num_soil_layers , num_st_levels_input , num_sm_levels_input , &
    3159. 

  3159.                                  num_st_levels_alloc , num_sm_levels_alloc , &
    3160. 

  3160.                                  flag_sst , flag_soilt000 , flag_soilm000 , &
    3161. 

  3161.                                  ids , ide , jds , jde , kds , kde , &
    3162. 

  3162.                                  ims , ime , jms , jme , kms , kme , &
    3163. 

  3163.                                  its , ite , jts , jte , kts , kte )
    3164. 

  3164.       END IF
    3165. 

  3165. 

  3166.    END SUBROUTINE process_soil_real
    3167. 

  3167. 

  3168.    SUBROUTINE process_soil_ideal ( xland,xice,vegfra,snow,canwat,  &
    3169. 

  3169.                                    ivgtyp,isltyp,tslb,smois, &
    3170. 

  3170.                                    tsk,tmn,zs,dzs,           &
    3171. 

  3171.                                    num_soil_layers,          &
    3172. 

  3172.                                    sf_surface_physics ,      &
    3173. 

  3173.                                    ids,ide, jds,jde, kds,kde,&
    3174. 

  3174.                                    ims,ime, jms,jme, kms,kme,&
    3175. 

  3175.                                    its,ite, jts,jte, kts,kte )
    3176. 

  3176. 

  3177.       IMPLICIT NONE
    3178. 

  3178. 

  3179.       INTEGER, INTENT(IN) ::ids,ide, jds,jde, kds,kde,  &
    3180. 

  3180.                             ims,ime, jms,jme, kms,kme,  &
    3181. 

  3181.                             its,ite, jts,jte, kts,kte
    3182. 

  3182. 

  3183.       INTEGER, INTENT(IN) :: num_soil_layers , sf_surface_physics
    3184. 

  3184. 

  3185.       REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , INTENT(INOUT) :: smois, tslb
    3186. 

  3186. 

  3187.       REAL, DIMENSION(num_soil_layers), INTENT(OUT) :: dzs,zs
    3188. 

  3188. 

  3189.       REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT) :: tsk, tmn
    3190. 

  3190.       REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: xland, snow, canwat, xice, vegfra
    3191. 

  3191.       INTEGER, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: ivgtyp, isltyp
    3192. 

  3192. 

  3193.       !  Local variables.
    3194. 

  3194. 

  3195.       INTEGER :: itf,jtf
    3196. 

  3196. 

  3197.       itf=MIN(ite,ide-1)
    3198. 

  3198.       jtf=MIN(jte,jde-1)
    3199. 

  3199. 

  3200.       IF      ( ( sf_surface_physics .EQ. SLABSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    3201. 

  3201.          CALL init_soil_depth_1 ( zs , dzs , num_soil_layers )
    3202. 

  3202.          CALL init_soil_1_ideal(tsk,tmn,tslb,xland,                      &
    3203. 

  3203.                                 ivgtyp,zs,dzs,num_soil_layers,           &
    3204. 

  3204.                                 ids,ide, jds,jde, kds,kde,               &
    3205. 

  3205.                                 ims,ime, jms,jme, kms,kme,               &
    3206. 

  3206.                                 its,ite, jts,jte, kts,kte                )
    3207. 

  3207.       ELSE IF ( ( sf_surface_physics .EQ. LSMSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    3208. 

  3208.          CALL init_soil_depth_2 ( zs , dzs , num_soil_layers )
    3209. 

  3209.          CALL init_soil_2_ideal ( xland,xice,vegfra,snow,canwat,         &
    3210. 

  3210.                                   ivgtyp,isltyp,tslb,smois,tmn,          &
    3211. 

  3211.                                   num_soil_layers,                       &
    3212. 

  3212.                                   ids,ide, jds,jde, kds,kde,             &
    3213. 

  3213.                                   ims,ime, jms,jme, kms,kme,             &
    3214. 

  3214.                                   its,ite, jts,jte, kts,kte              )
    3215. 

  3215.       ELSE IF ( ( sf_surface_physics .EQ. NOAHMPSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    3216. 

  3216.          CALL init_soil_depth_2 ( zs , dzs , num_soil_layers )
    3217. 

  3217.          CALL init_soil_2_ideal ( xland,xice,vegfra,snow,canwat,         &
    3218. 

  3218.                                   ivgtyp,isltyp,tslb,smois,tmn,          &
    3219. 

  3219.                                   num_soil_layers,                       &
    3220. 

  3220.                                   ids,ide, jds,jde, kds,kde,             &
    3221. 

  3221.                                   ims,ime, jms,jme, kms,kme,             &
    3222. 

  3222.                                   its,ite, jts,jte, kts,kte              )
    3223. 

  3223.       ELSE IF ( ( sf_surface_physics .EQ. RUCLSMSCHEME ) .AND. ( num_soil_layers .GT. 1 ) ) THEN
    3224. 

  3224.          CALL init_soil_depth_3 ( zs , dzs , num_soil_layers )
    3225. 

  3225. 

  3226.       END IF
    3227. 

  3227. 

  3228.    END SUBROUTINE process_soil_ideal
    3229. 

  3229. 

  3230.    SUBROUTINE adjust_soil_temp_new ( tmn , sf_surface_physics , &
    3231. 

  3231.                                  tsk , ter , toposoil , landmask , flag_toposoil , &
    3232. 

  3232.                                       st000010 ,      st010040 ,      st040100 ,      st100200 ,      st010200 , &
    3233. 

  3233.                                  flag_st000010 , flag_st010040 , flag_st040100 , flag_st100200 , flag_st010200 , &
    3234. 

  3234.                                       soilt000 ,      soilt005 ,      soilt020 ,      soilt040 ,      soilt160 ,      soilt300 , &
    3235. 

  3235.                                  flag_soilt000 , flag_soilt005 , flag_soilt020 , flag_soilt040 , flag_soilt160 , flag_soilt300 , &
    3236. 

  3236.                                  ids , ide , jds , jde , kds , kde , &
    3237. 

  3237.                                  ims , ime , jms , jme , kms , kme , &
    3238. 

  3238.                                  its , ite , jts , jte , kts , kte )
    3239. 

  3239. 

  3240.       IMPLICIT NONE
    3241. 

  3241. 

  3242.       INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
    3243. 

  3243.                               ims , ime , jms , jme , kms , kme , &
    3244. 

  3244.                               its , ite , jts , jte , kts , kte
    3245. 

  3245. 

  3246.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN)    :: ter , toposoil , landmask
    3247. 

  3247.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tmn , tsk
    3248. 

  3248.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: st000010 , st010040 , st040100 , st100200 , st010200
    3249. 

  3249.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: soilt000 , soilt005 , soilt020 , soilt040 , soilt160 , soilt300
    3250. 

  3250. 

  3251.       INTEGER , INTENT(IN) :: flag_st000010 , flag_st010040 , flag_st040100 , flag_st100200 , flag_st010200
    3252. 

  3252.       INTEGER , INTENT(IN) :: flag_soilt000 , flag_soilt005 , flag_soilt020 , flag_soilt040 , flag_soilt160 , flag_soilt300
    3253. 

  3253.       INTEGER , INTENT(IN) :: sf_surface_physics , flag_toposoil
    3254. 

  3254. 

  3255.       INTEGER :: i , j
    3256. 

  3256. 

  3257.       REAL :: soil_elev_min_val ,  soil_elev_max_val , soil_elev_min_dif , soil_elev_max_dif
    3258. 

  3258. 

  3259.       !  Do we have a soil field with which to modify soil temperatures?
    3260. 

  3260. 

  3261.       IF ( flag_toposoil .EQ. 1 ) THEN
    3262. 

  3262. 

  3263.          DO j = jts , MIN(jde-1,jte)
    3264. 

  3264.             DO i = its , MIN(ide-1,ite)
    3265. 

  3265. 

  3266.                !  Is the toposoil field OK, or is it a subversive soil elevation field.  We can tell
    3267. 

  3267.                !  usually by looking at values.  Anything less than -1000 m (lower than the Dead Sea) is
    3268. 

  3268.                !  bad.  Anything larger than 10 km (taller than Everest) is toast.  Also, anything where
    3269. 

  3269.                !  the difference between the soil elevation and the terrain is greater than 3 km means
    3270. 

  3270.                !  that the soil data is either all zeros or that the data are inconsistent.  Any of these
    3271. 

  3271.                !  three conditions is grievous enough to induce a WRF fatality.  However, if they are at
    3272. 

  3272.                !  a water point, then we can safely ignore them.
    3273. 

  3273. 

  3274.                soil_elev_min_val = toposoil(i,j)
    3275. 

  3275.                soil_elev_max_val = toposoil(i,j)
    3276. 

  3276.                soil_elev_min_dif = ter(i,j) - toposoil(i,j)
    3277. 

  3277.                soil_elev_max_dif = ter(i,j) - toposoil(i,j)
    3278. 

  3278. 

  3279.                IF      ( ( soil_elev_min_val .LT. -1000 ) .AND. ( landmask(i,j) .LT. 0.5 ) ) THEN
    3280. 

  3280.                   CYCLE
    3281. 

  3281.                ELSE IF ( ( soil_elev_min_val .LT. -1000 ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
    3282. 

  3282. !print *,'no soil temperature elevation adjustment, soil height too small = ',toposoil(i,j)
    3283. 

  3283. cycle
    3284. 

  3284. !                 CALL wrf_error_fatal ( 'TOPOSOIL values have large negative values < -1000 m, unrealistic.' )
    3285. 

  3285.                ENDIF
    3286. 

  3286. 

  3287.                IF      ( ( soil_elev_max_val .GT. 10000 ) .AND. ( landmask(i,j) .LT. 0.5 ) ) THEN
    3288. 

  3288.                   CYCLE
    3289. 

  3289.                ELSE IF ( ( soil_elev_max_val .GT. 10000 ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
    3290. 

  3290. print *,'no soil temperature elevation adjustment, soil height too high = ',toposoil(i,j)
    3291. 

  3291. cycle
    3292. 

  3292.                   CALL wrf_error_fatal ( 'TOPOSOIL values have large positive values > 10,000 m , unrealistic.' )
    3293. 

  3293.                ENDIF
    3294. 

  3294. 

  3295.                IF      ( ( ( soil_elev_min_dif .LT. -3000 ) .OR. ( soil_elev_max_dif .GT. 3000 ) ) .AND. &
    3296. 

  3296.                            ( landmask(i,j) .LT. 0.5 ) ) THEN
    3297. 

  3297.                   CYCLE
    3298. 

  3298.                ELSE IF ( ( ( soil_elev_min_dif .LT. -3000 ) .OR. ( soil_elev_max_dif .GT. 3000 ) ) .AND. &
    3299. 

  3299.                            ( landmask(i,j) .GT. 0.5 ) ) THEN
    3300. 

  3300. print *,'no soil temperature elevation adjustment, diff of soil height and terrain = ',ter(i,j) - toposoil(i,j)
    3301. 

  3301. cycle
    3302. 

  3302.                   CALL wrf_error_fatal ( 'TOPOSOIL difference with terrain elevation differs by more than 3000 m, unrealistic' )
    3303. 

  3303.                ENDIF
    3304. 

  3304. 

  3305.                !  For each of the fields that we would like to modify, check to see if it came in from the SI.
    3306. 

  3306.                !  If so, then use a -6.5 K/km lapse rate (based on the elevation diffs).  We only adjust when we
    3307. 

  3307.                !  are not at a water point.
    3308. 

  3308. 

  3309.                IF (landmask(i,j) .GT. 0.5 ) THEN
    3310. 

  3310. 

  3311.                   IF ( sf_surface_physics .EQ. SLABSCHEME .OR. sf_surface_physics .EQ. PXLSMSCHEME ) THEN
    3312. 

  3312.                      tmn(i,j) = tmn(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    3313. 

  3313.                   END IF
    3314. 

  3314. 

  3315.                   tsk(i,j) = tsk(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    3316. 

  3316. 

  3317.                   IF ( flag_st000010 .EQ. 1 ) THEN
    3318. 

  3318.                      st000010(i,j) = st000010(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    3319. 

  3319.                   END IF
    3320. 

  3320.                   IF ( flag_st010040 .EQ. 1 ) THEN
    3321. 

  3321.                      st010040(i,j) = st010040(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    3322. 

  3322.                   END IF
    3323. 

  3323.                   IF ( flag_st040100 .EQ. 1 ) THEN
    3324. 

  3324.                      st040100(i,j) = st040100(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    3325. 

  3325.                   END IF
    3326. 

  3326.                   IF ( flag_st100200 .EQ. 1 ) THEN
    3327. 

  3327.                      st100200(i,j) = st100200(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    3328. 

  3328.                   END IF
    3329. 

  3329.                   IF ( flag_st010200 .EQ. 1 ) THEN
    3330. 

  3330.                      st010200(i,j) = st010200(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    3331. 

  3331.                   END IF
    3332. 

  3332. 

  3333.                   IF ( flag_soilt000 .EQ. 1 ) THEN
    3334. 

  3334.                      soilt000(i,j) = soilt000(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    3335. 

  3335.                   END IF
    3336. 

  3336.                   IF ( flag_soilt005 .EQ. 1 ) THEN
    3337. 

  3337.                      soilt005(i,j) = soilt005(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    3338. 

  3338.                   END IF
    3339. 

  3339.                   IF ( flag_soilt020 .EQ. 1 ) THEN
    3340. 

  3340.                      soilt020(i,j) = soilt020(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    3341. 

  3341.                   END IF
    3342. 

  3342.                   IF ( flag_soilt040 .EQ. 1 ) THEN
    3343. 

  3343.                      soilt040(i,j) = soilt040(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    3344. 

  3344.                   END IF
    3345. 

  3345.                   IF ( flag_soilt160 .EQ. 1 ) THEN
    3346. 

  3346.                      soilt160(i,j) = soilt160(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    3347. 

  3347.                   END IF
    3348. 

  3348.                   IF ( flag_soilt300 .EQ. 1 ) THEN
    3349. 

  3349.                      soilt300(i,j) = soilt300(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) )
    3350. 

  3350.                   END IF
    3351. 

  3351. 

  3352.                END IF
    3353. 

  3353.             END DO
    3354. 

  3354.          END DO
    3355. 

  3355. 

  3356.       END IF
    3357. 

  3357. 

  3358.    END SUBROUTINE adjust_soil_temp_new
    3359. 

  3359. 

  3360. 

  3361.    SUBROUTINE init_soil_depth_1 ( zs , dzs , num_soil_layers )
    3362. 

  3362. 

  3363.       IMPLICIT NONE
    3364. 

  3364. 

  3365.       INTEGER, INTENT(IN) :: num_soil_layers
    3366. 

  3366. 

  3367.       REAL, DIMENSION(1:num_soil_layers), INTENT(OUT)  ::  zs,dzs
    3368. 

  3368. 

  3369.       INTEGER                   ::      l
    3370. 

  3370. 

  3371.       CHARACTER (LEN=132) :: message
    3372. 

  3372. 

  3373.       !  Define layers (top layer = 0.01 m).  Double the thicknesses at each step (dzs values).
    3374. 

  3374.       !  The distance from the ground level to the midpoint of the layer is given by zs.
    3375. 

  3375. 

  3376.       !    -------   Ground Level   ----------      ||      ||   ||  ||
    3377. 

  3377.       !                                             ||      ||   ||  || zs(1) = 0.005 m
    3378. 

  3378.       !    --  --  --  --  --  --  --  --  --       ||      ||   ||  \/
    3379. 

  3379.       !                                             ||      ||   ||
    3380. 

  3380.       !    -----------------------------------      ||  ||  ||   \/   dzs(1) = 0.01 m
    3381. 

  3381.       !                                             ||  ||  ||
    3382. 

  3382.       !                                             ||  ||  || zs(2) = 0.02
    3383. 

  3383.       !    --  --  --  --  --  --  --  --  --       ||  ||  \/
    3384. 

  3384.       !                                             ||  ||
    3385. 

  3385.       !                                             ||  ||
    3386. 

  3386.       !    -----------------------------------  ||  ||  \/   dzs(2) = 0.02 m
    3387. 

  3387.       !                                         ||  ||
    3388. 

  3388.       !                                         ||  ||
    3389. 

  3389.       !                                         ||  ||
    3390. 

  3390.       !                                         ||  || zs(3) = 0.05
    3391. 

  3391.       !    --  --  --  --  --  --  --  --  --   ||  \/
    3392. 

  3392.       !                                         ||
    3393. 

  3393.       !                                         ||
    3394. 

  3394.       !                                         ||
    3395. 

  3395.       !                                         ||
    3396. 

  3396.       !    -----------------------------------  \/   dzs(3) = 0.04 m
    3397. 

  3397. 

  3398.       IF ( num_soil_layers .NE. 5 ) THEN
    3399. 

  3399.          write(message,FMT= '(A)') 'Usually, the 5-layer diffusion uses 5 layers.  Change this in the namelist.'
    3400. 

  3400.          CALL wrf_error_fatal ( message )
    3401. 

  3401.       END IF
    3402. 

  3402. 

  3403.       dzs(1)=.01
    3404. 

  3404.       zs(1)=.5*dzs(1)
    3405. 

  3405. 

  3406.       DO l=2,num_soil_layers
    3407. 

  3407.          dzs(l)=2*dzs(l-1)
    3408. 

  3408.          zs(l)=zs(l-1)+.5*dzs(l-1)+.5*dzs(l)
    3409. 

  3409.       ENDDO
    3410. 

  3410. 

  3411.    END SUBROUTINE init_soil_depth_1
    3412. 

  3412. 

  3413.    SUBROUTINE init_soil_depth_2 ( zs , dzs , num_soil_layers )
    3414. 

  3414. 

  3415.       IMPLICIT NONE
    3416. 

  3416. 

  3417.       INTEGER, INTENT(IN) :: num_soil_layers
    3418. 

  3418. 

  3419.       REAL, DIMENSION(1:num_soil_layers), INTENT(OUT)  ::  zs,dzs
    3420. 

  3420. 

  3421.       INTEGER                   ::      l
    3422. 

  3422. 

  3423.       CHARACTER (LEN=132) :: message
    3424. 

  3424. 

  3425.       dzs = (/ 0.1 , 0.3 , 0.6 , 1.0 /)
    3426. 

  3426. 

  3427.       IF ( num_soil_layers .NE. 4 ) THEN
    3428. 

  3428.          write(message,FMT='(A)') 'Usually, the LSM uses 4 layers.  Change this in the namelist.'
    3429. 

  3429.          CALL wrf_error_fatal ( message )
    3430. 

  3430.       END IF
    3431. 

  3431. 

  3432.       zs(1)=.5*dzs(1)
    3433. 

  3433. 

  3434.       DO l=2,num_soil_layers
    3435. 

  3435.          zs(l)=zs(l-1)+.5*dzs(l-1)+.5*dzs(l)
    3436. 

  3436.       ENDDO
    3437. 

  3437. 

  3438.    END SUBROUTINE init_soil_depth_2
    3439. 

  3439. 

  3440.    SUBROUTINE init_soil_depth_3 ( zs , dzs , num_soil_layers )
    3441. 

  3441. 

  3442.       IMPLICIT NONE
    3443. 

  3443. 

  3444.       INTEGER, INTENT(IN) :: num_soil_layers
    3445. 

  3445. 

  3446.       REAL, DIMENSION(1:num_soil_layers), INTENT(OUT)  ::  zs,dzs
    3447. 

  3447. 

  3448.       INTEGER                   ::      l
    3449. 

  3449. 

  3450.       CHARACTER (LEN=132) :: message
    3451. 

  3451. 

  3452. ! in RUC LSM ZS - soil levels, and DZS - soil layer thicknesses, not used
    3453. 

  3453. ! ZS is specified in the namelist: num_soil_layers = 6 or 9.
    3454. 

  3454. ! Other options with number of levels are possible, but
    3455. 

  3455. ! WRF users should change consistently the namelist entry with the
    3456. 

  3456. !    ZS array in this subroutine.
    3457. 

  3457. 

  3458.      IF ( num_soil_layers .EQ. 6) THEN
    3459. 

  3459.       zs  = (/ 0.00 , 0.05 , 0.20 , 0.40 , 1.60 , 3.00 /)
    3460. 

  3460. !      dzs = (/ 0.00 , 0.125, 0.175 , 0.70 , 1.30 , 1.40 /)
    3461. 

  3461.      ELSEIF ( num_soil_layers .EQ. 9) THEN
    3462. 

  3462.       zs  = (/ 0.00 , 0.05 , 0.20 , 0.40 , 0.60, 1.00, 1.60 , 2.20, 3.00 /)
    3463. 

  3463. !      dzs = (/ 0.00 , 0.125, 0.175 , 0.70 , 1.30 , 1.40 /)
    3464. 

  3464.      ENDIF
    3465. 

  3465. 

  3466.       IF ( num_soil_layers .EQ. 4 .OR. num_soil_layers .EQ. 5 ) THEN
    3467. 

  3467.          WRITE(message,FMT= '(A)')'Usually, the RUC LSM uses 6, 9 or more levels.  Change this in the namelist.'
    3468. 

  3468.          CALL wrf_error_fatal ( message )
    3469. 

  3469.       END IF
    3470. 

  3470. 

  3471.    END SUBROUTINE init_soil_depth_3
    3472. 

  3472. 

  3473.    SUBROUTINE init_soil_1_real ( tsk , tmn , tslb , zs , dzs , &
    3474. 

  3474.                                  num_soil_layers , real_data_init_type , &
    3475. 

  3475.                                  landmask , sst , flag_sst , &
    3476. 

  3476.                                  ids , ide , jds , jde , kds , kde , &
    3477. 

  3477.                                  ims , ime , jms , jme , kms , kme , &
    3478. 

  3478.                                  its , ite , jts , jte , kts , kte )
    3479. 

  3479. 

  3480.       IMPLICIT NONE
    3481. 

  3481. 

  3482.       INTEGER , INTENT(IN) :: num_soil_layers , real_data_init_type , &
    3483. 

  3483.                               ids , ide , jds , jde , kds , kde , &
    3484. 

  3484.                               ims , ime , jms , jme , kms , kme , &
    3485. 

  3485.                               its , ite , jts , jte , kts , kte
    3486. 

  3486. 

  3487.       INTEGER , INTENT(IN) :: flag_sst
    3488. 

  3488. 

  3489.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst
    3490. 

  3490.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tsk , tmn
    3491. 

  3491. 

  3492.       REAL , DIMENSION(num_soil_layers) :: zs , dzs
    3493. 

  3493. 

  3494.       REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb
    3495. 

  3495. 

  3496.       INTEGER :: i , j , l
    3497. 

  3497. 

  3498.       !  Soil temperature is linearly interpolated between the skin temperature (taken to be at a
    3499. 

  3499.       !  depth of 0.5 cm) and the deep soil, annual temperature (taken to be at a depth of 23 cm).
    3500. 

  3500.       !  The tslb(i,1,j) is the skin temperature, and the tslb(i,num_soil_layers,j) level is the
    3501. 

  3501.       !  annual mean temperature.
    3502. 

  3502. 

  3503.       DO j = jts , MIN(jde-1,jte)
    3504. 

  3504.          DO i = its , MIN(ide-1,ite)
    3505. 

  3505.             IF ( landmask(i,j) .GT. 0.5 ) THEN
    3506. 

  3506.                DO l = 1 , num_soil_layers
    3507. 

  3507.                   tslb(i,l,j)= ( tsk(i,j) * ( zs(num_soil_layers) - zs(l) )   + &
    3508. 

  3508.                                  tmn(i,j) * ( zs(              l) - zs(1) ) ) / &
    3509. 

  3509.                                             ( zs(num_soil_layers) - zs(1) )
    3510. 

  3510.                END DO
    3511. 

  3511.             ELSE
    3512. 

  3512.                IF ( ( real_data_init_type .EQ. 1 ) .AND. ( flag_sst .EQ. 1 ) ) THEN
    3513. 

  3513.                   DO l = 1 , num_soil_layers
    3514. 

  3514.                      tslb(i,l,j)= sst(i,j)
    3515. 

  3515.                   END DO
    3516. 

  3516.                ELSE
    3517. 

  3517.                   DO l = 1 , num_soil_layers
    3518. 

  3518.                      tslb(i,l,j)= tsk(i,j)
    3519. 

  3519.                   END DO
    3520. 

  3520.                END IF
    3521. 

  3521.             END IF
    3522. 

  3522.          END DO
    3523. 

  3523.       END DO
    3524. 

  3524. 

  3525.    END SUBROUTINE init_soil_1_real
    3526. 

  3526. 

  3527.    SUBROUTINE init_soil_1_ideal(tsk,tmn,tslb,xland,             &
    3528. 

  3528.                        ivgtyp,ZS,DZS,num_soil_layers,           &
    3529. 

  3529.                        ids,ide, jds,jde, kds,kde,               &
    3530. 

  3530.                        ims,ime, jms,jme, kms,kme,               &
    3531. 

  3531.                        its,ite, jts,jte, kts,kte                )
    3532. 

  3532. 

  3533.       IMPLICIT NONE
    3534. 

  3534. 

  3535.       INTEGER, INTENT(IN   )    ::      ids,ide, jds,jde, kds,kde, &
    3536. 

  3536.                                         ims,ime, jms,jme, kms,kme, &
    3537. 

  3537.                                         its,ite, jts,jte, kts,kte
    3538. 

  3538. 

  3539.       INTEGER, INTENT(IN   )    ::      num_soil_layers
    3540. 

  3540. 

  3541.       REAL, DIMENSION( ims:ime , 1 , jms:jme ), INTENT(OUT) :: tslb
    3542. 

  3542.       REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: xland
    3543. 

  3543.       INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: ivgtyp
    3544. 

  3544. 

  3545.       REAL, DIMENSION(1:), INTENT(IN) :: dzs,zs
    3546. 

  3546. 

  3547.       REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(IN) :: tsk, tmn
    3548. 

  3548. 

  3549.       !  Lcal variables.
    3550. 

  3550. 

  3551.       INTEGER :: l,j,i,itf,jtf
    3552. 

  3552. 

  3553.       itf=MIN(ite,ide-1)
    3554. 

  3554.       jtf=MIN(jte,jde-1)
    3555. 

  3555. 

  3556.       IF (num_soil_layers.NE.1)THEN
    3557. 

  3557.          DO j=jts,jtf
    3558. 

  3558.             DO l=1,num_soil_layers
    3559. 

  3559.                DO i=its,itf
    3560. 

  3560.                  tslb(i,l,j)=( tsk(i,j)*(zs(num_soil_layers)-zs(l)) + tmn(i,j)*(zs(l)-zs(1)) ) / &
    3561. 

  3561.                              ( zs(num_soil_layers)-zs(1) )
    3562. 

  3562.                ENDDO
    3563. 

  3563.             ENDDO
    3564. 

  3564.          ENDDO
    3565. 

  3565.       ENDIF
    3566. 

  3566.       DO j=jts,jtf
    3567. 

  3567.          DO i=its,itf
    3568. 

  3568.            xland(i,j)  = 2
    3569. 

  3569.            ivgtyp(i,j) = 7
    3570. 

  3570.          ENDDO
    3571. 

  3571.       ENDDO
    3572. 

  3572. 

  3573.    END SUBROUTINE init_soil_1_ideal
    3574. 

  3574. 

  3575.    SUBROUTINE init_soil_2_real ( tsk , tmn , smois , sh2o , tslb , &
    3576. 

  3576.                                  st_input , sm_input , sw_input , landmask , sst , &
    3577. 

  3577.                                  zs , dzs , &
    3578. 

  3578.                                  st_levels_input , sm_levels_input , sw_levels_input , &
    3579. 

  3579.                                  num_soil_layers , num_st_levels_input , num_sm_levels_input ,  num_sw_levels_input , &
    3580. 

  3580.                                  num_st_levels_alloc , num_sm_levels_alloc ,  num_sw_levels_alloc , &
    3581. 

  3581.                                  flag_sst , flag_soilt000 , flag_soilm000 , &
    3582. 

  3582.                                  ids , ide , jds , jde , kds , kde , &
    3583. 

  3583.                                  ims , ime , jms , jme , kms , kme , &
    3584. 

  3584.                                  its , ite , jts , jte , kts , kte )
    3585. 

  3585. 

  3586.       IMPLICIT NONE
    3587. 

  3587. 

  3588.       INTEGER , INTENT(IN) :: num_soil_layers , &
    3589. 

  3589.                               num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
    3590. 

  3590.                               num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , &
    3591. 

  3591.                               ids , ide , jds , jde , kds , kde , &
    3592. 

  3592.                               ims , ime , jms , jme , kms , kme , &
    3593. 

  3593.                               its , ite , jts , jte , kts , kte
    3594. 

  3594. 

  3595.       INTEGER , INTENT(IN) :: flag_sst, flag_soilt000, flag_soilm000
    3596. 

  3596. 

  3597.       INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input
    3598. 

  3598.       INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input
    3599. 

  3599.       INTEGER , DIMENSION(1:num_sw_levels_input) , INTENT(INOUT) :: sw_levels_input
    3600. 

  3600. 

  3601.       REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input
    3602. 

  3602.       REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input
    3603. 

  3603.       REAL , DIMENSION(ims:ime,1:num_sw_levels_alloc,jms:jme) , INTENT(INOUT) :: sw_input
    3604. 

  3604.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst
    3605. 

  3605. 

  3606.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn
    3607. 

  3607.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk
    3608. 

  3608.       REAL , DIMENSION(num_soil_layers) :: zs , dzs
    3609. 

  3609. 

  3610.       REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois , sh2o
    3611. 

  3611. 

  3612.       REAL , ALLOCATABLE , DIMENSION(:) :: zhave
    3613. 

  3613. 

  3614.       INTEGER :: i , j , l , lout , lin , lwant , lhave , num
    3615. 

  3615.       REAL :: temp
    3616. 

  3616.       LOGICAL :: found_levels
    3617. 

  3617. 

  3618.       CHARACTER (LEN=132) :: message
    3619. 

  3619. 

  3620.       !  Are there any soil temp and moisture levels - ya know, they are mandatory.
    3621. 

  3621. 

  3622.       num = num_st_levels_input * num_sm_levels_input
    3623. 

  3623. 

  3624.       IF ( num .GE. 1 ) THEN
    3625. 

  3625. 

  3626.          !  Ordered levels that we have data for.
    3627. 

  3627.          IF ( flag_soilt000 .eq. 1 ) THEN
    3628. 

  3628.            write(message, FMT='(A)') ' Assume RUC LSM 6-level input'
    3629. 

  3629.            CALL wrf_message ( message )
    3630. 

  3630.            ALLOCATE ( zhave( MAX(num_st_levels_input,num_sm_levels_input,num_sw_levels_input)  ) )
    3631. 

  3631.          ELSE
    3632. 

  3632.            write(message, FMT='(A)') ' Assume Noah LSM input'
    3633. 

  3633.            CALL wrf_message ( message )
    3634. 

  3634.          ALLOCATE ( zhave( MAX(num_st_levels_input,num_sm_levels_input,num_sw_levels_input) +2) )
    3635. 

  3635.          END IF
    3636. 

  3636. 

  3637. 

  3638.          !  Sort the levels for temperature.
    3639. 

  3639. !print*,'num_st_levels_input, st_levels_input', num_st_levels_input, st_levels_input
    3640. 

  3640. !print*,'num_sm_levels_input,num_sw_levels_input',num_sm_levels_input,num_sw_levels_input
    3641. 

  3641. 

  3642.          outert : DO lout = 1 , num_st_levels_input-1
    3643. 

  3643.             innert : DO lin = lout+1 , num_st_levels_input
    3644. 

  3644.                IF ( st_levels_input(lout) .GT. st_levels_input(lin) ) THEN
    3645. 

  3645.                   temp = st_levels_input(lout)
    3646. 

  3646.                   st_levels_input(lout) = st_levels_input(lin)
    3647. 

  3647.                   st_levels_input(lin) = NINT(temp)
    3648. 

  3648.                   DO j = jts , MIN(jde-1,jte)
    3649. 

  3649.                      DO i = its , MIN(ide-1,ite)
    3650. 

  3650.                         temp = st_input(i,lout+1,j)
    3651. 

  3651.                         st_input(i,lout+1,j) = st_input(i,lin+1,j)
    3652. 

  3652.                         st_input(i,lin+1,j) = temp
    3653. 

  3653.                      END DO
    3654. 

  3654.                   END DO
    3655. 

  3655.                END IF
    3656. 

  3656.             END DO innert
    3657. 

  3657.          END DO outert
    3658. 

  3658. !tgs add IF
    3659. 

  3659.       IF ( flag_soilt000 .NE. 1 ) THEN
    3660. 

  3660.          DO j = jts , MIN(jde-1,jte)
    3661. 

  3661.             DO i = its , MIN(ide-1,ite)
    3662. 

  3662.                st_input(i,1,j) = tsk(i,j)
    3663. 

  3663.                st_input(i,num_st_levels_input+2,j) = tmn(i,j)
    3664. 

  3664.             END DO
    3665. 

  3665.          END DO
    3666. 

  3666.       ENDIF
    3667. 

  3667. 

  3668. 

  3669. #if ( NMM_CORE == 1 )
    3670. 

  3670. !new
    3671. 

  3671. !       write(0,*) 'st_input(1) in init_soil_2_real'
    3672. 

  3672. !	DO J=MIN(jde-1,jte),JTS, -MIN(jde-1,jte)/15
    3673. 

  3673. !       write(0,616) (st_input(I,1,J),I=its , MIN(ide-1,ite),MIN(ide-1,ite)/10)
    3674. 

  3674. !	ENDDO
    3675. 

  3675. 

  3676. !       write(0,*) 'st_input(2) in init_soil_2_real'
    3677. 

  3677. !	DO J=MIN(jde-1,jte),JTS, -MIN(jde-1,jte)/15
    3678. 

  3678. !       write(0,616) (st_input(I,2,J),I=its , MIN(ide-1,ite),MIN(ide-1,ite)/10)
    3679. 

  3679. !	ENDDO
    3680. 

  3680. 

  3681.   616	format(20(f4.0,1x))
    3682. 

  3682. #endif
    3683. 

  3683. 

  3684.          !  Sort the levels for moisture.
    3685. 

  3685. 

  3686.          outerm: DO lout = 1 , num_sm_levels_input-1
    3687. 

  3687.             innerm : DO lin = lout+1 , num_sm_levels_input
    3688. 

  3688.                IF ( sm_levels_input(lout) .GT. sm_levels_input(lin) ) THEN
    3689. 

  3689.                   temp = sm_levels_input(lout)
    3690. 

  3690.                   sm_levels_input(lout) = sm_levels_input(lin)
    3691. 

  3691.                   sm_levels_input(lin) = NINT(temp)
    3692. 

  3692.                   DO j = jts , MIN(jde-1,jte)
    3693. 

  3693.                      DO i = its , MIN(ide-1,ite)
    3694. 

  3694.                         temp = sm_input(i,lout+1,j)
    3695. 

  3695.                         sm_input(i,lout+1,j) = sm_input(i,lin+1,j)
    3696. 

  3696.                         sm_input(i,lin+1,j) = temp
    3697. 

  3697.                      END DO
    3698. 

  3698.                   END DO
    3699. 

  3699.                END IF
    3700. 

  3700.             END DO innerm
    3701. 

  3701.          END DO outerm
    3702. 

  3702. !tgs add IF
    3703. 

  3703.       IF ( flag_soilm000 .NE. 1 ) THEN
    3704. 

  3704.          DO j = jts , MIN(jde-1,jte)
    3705. 

  3705.             DO i = its , MIN(ide-1,ite)
    3706. 

  3706.                sm_input(i,1,j) = sm_input(i,2,j)
    3707. 

  3707.                sm_input(i,num_sm_levels_input+2,j) = sm_input(i,num_sm_levels_input+1,j)
    3708. 

  3708.             END DO
    3709. 

  3709.          END DO
    3710. 

  3710.       ENDIF
    3711. 

  3711. 

  3712.          !  Sort the levels for liquid moisture.
    3713. 

  3713. 

  3714.          outerw: DO lout = 1 , num_sw_levels_input-1
    3715. 

  3715.             innerw : DO lin = lout+1 , num_sw_levels_input
    3716. 

  3716.                IF ( sw_levels_input(lout) .GT. sw_levels_input(lin) ) THEN
    3717. 

  3717.                   temp = sw_levels_input(lout)
    3718. 

  3718.                   sw_levels_input(lout) = sw_levels_input(lin)
    3719. 

  3719.                   sw_levels_input(lin) = NINT(temp)
    3720. 

  3720.                   DO j = jts , MIN(jde-1,jte)
    3721. 

  3721.                      DO i = its , MIN(ide-1,ite)
    3722. 

  3722.                         temp = sw_input(i,lout+1,j)
    3723. 

  3723.                         sw_input(i,lout+1,j) = sw_input(i,lin+1,j)
    3724. 

  3724.                         sw_input(i,lin+1,j) = temp
    3725. 

  3725.                      END DO
    3726. 

  3726.                   END DO
    3727. 

  3727.                END IF
    3728. 

  3728.             END DO innerw
    3729. 

  3729.          END DO outerw
    3730. 

  3730.          IF ( num_sw_levels_input .GT. 1 ) THEN
    3731. 

  3731.             DO j = jts , MIN(jde-1,jte)
    3732. 

  3732.                DO i = its , MIN(ide-1,ite)
    3733. 

  3733.                   sw_input(i,1,j) = sw_input(i,2,j)
    3734. 

  3734.                   sw_input(i,num_sw_levels_input+2,j) = sw_input(i,num_sw_levels_input+1,j)
    3735. 

  3735.                END DO
    3736. 

  3736.             END DO
    3737. 

  3737.          END IF
    3738. 

  3738. 

  3739.          found_levels = .TRUE.
    3740. 

  3740. 

  3741.       ELSE IF ( ( num .LE. 0 ) .AND. (  start_date .NE. current_date ) ) THEN
    3742. 

  3742. 

  3743.          found_levels = .FALSE.
    3744. 

  3744. 

  3745.       ELSE
    3746. 

  3746.          CALL wrf_error_fatal ( &
    3747. 

  3747.          'No input soil level data (temperature, moisture or liquid, or all are missing). Required for LSM.' )
    3748. 

  3748.       END IF
    3749. 

  3749. 

  3750.       !  Is it OK to continue?
    3751. 

  3751. 

  3752.       IF ( found_levels ) THEN
    3753. 

  3753. 

  3754. !tgs add IF
    3755. 

  3755.       IF ( flag_soilt000 .NE.1) THEN
    3756. 

  3756. !tgs initialize from Noah data
    3757. 

  3757.          !  Here are the levels that we have from the input for temperature.  The input levels plus
    3758. 

  3758.          !  two more: the skin temperature at 0 cm, and the annual mean temperature at 300 cm.
    3759. 

  3759. 

  3760.          zhave(1) = 0.
    3761. 

  3761.          DO l = 1 , num_st_levels_input
    3762. 

  3762.             zhave(l+1) = st_levels_input(l) / 100.
    3763. 

  3763.          END DO
    3764. 

  3764.          zhave(num_st_levels_input+2) = 300. / 100.
    3765. 

  3765. 

  3766.          !  Interpolate between the layers we have (zhave) and those that we want (zs).
    3767. 

  3767. 

  3768.          z_wantt : DO lwant = 1 , num_soil_layers
    3769. 

  3769.             z_havet : DO lhave = 1 , num_st_levels_input +2 -1
    3770. 

  3770.                IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    3771. 

  3771.                     ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    3772. 

  3772.                   DO j = jts , MIN(jde-1,jte)
    3773. 

  3773.                      DO i = its , MIN(ide-1,ite)
    3774. 

  3774.                         tslb(i,lwant,j)= ( st_input(i,lhave  ,j) * ( zhave(lhave+1) - zs   (lwant) ) + &
    3775. 

  3775.                                            st_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    3776. 

  3776.                                                                    ( zhave(lhave+1) - zhave(lhave) )
    3777. 

  3777.                      END DO
    3778. 

  3778.                   END DO
    3779. 

  3779.                   EXIT z_havet
    3780. 

  3780.                END IF
    3781. 

  3781.             END DO z_havet
    3782. 

  3782.          END DO z_wantt
    3783. 

  3783. 

  3784.      ELSE
    3785. 

  3785. 

  3786. !tgs initialize from RUCLSM data
    3787. 

  3787.          DO l = 1 , num_st_levels_input
    3788. 

  3788.             zhave(l) = st_levels_input(l) / 100.
    3789. 

  3789.          END DO
    3790. 

  3790. 

  3791.       !  Interpolate between the layers we have (zhave) and those that we want (zs).
    3792. 

  3792. 

  3793. 

  3794.       z_wantt_2 : DO lwant = 1 , num_soil_layers
    3795. 

  3795.          z_havet_2 : DO lhave = 1 , num_st_levels_input -1
    3796. 

  3796.             IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    3797. 

  3797.                  ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    3798. 

  3798.                DO j = jts , MIN(jde-1,jte)
    3799. 

  3799.                   DO i = its , MIN(ide-1,ite)
    3800. 

  3800.                      tslb(i,lwant,j)= ( st_input(i,lhave,j ) * ( zhave(lhave+1) - zs   (lwant) ) + &
    3801. 

  3801.                                         st_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    3802. 

  3802.                                                                 ( zhave(lhave+1) - zhave(lhave) )
    3803. 

  3803.                   END DO
    3804. 

  3804.                END DO
    3805. 

  3805.                EXIT z_havet_2
    3806. 

  3806.             END IF
    3807. 

  3807.          END DO z_havet_2
    3808. 

  3808.       END DO z_wantt_2
    3809. 

  3809. 

  3810.       ENDIF
    3811. 

  3811. 

  3812. 

  3813.       IF ( flag_soilm000 .NE. 1 ) THEN
    3814. 

  3814. !tgs initialize from Noah
    3815. 

  3815.          !  Here are the levels that we have from the input for moisture.  The input levels plus
    3816. 

  3816.          !  two more: a value at 0 cm and one at 300 cm.  The 0 cm value is taken to be identical
    3817. 

  3817.          !  to the most shallow layer's value.  Similarly, the 300 cm value is taken to be the same
    3818. 

  3818.          !  as the most deep layer's value.
    3819. 

    3820. 

  3820.          zhave(1) = 0.
    3821. 

  3821.          DO l = 1 , num_sm_levels_input
    3822. 

  3822.             zhave(l+1) = sm_levels_input(l) / 100.
    3823. 

  3823.          END DO
    3824. 

  3824.          zhave(num_sm_levels_input+2) = 300. / 100.
    3825. 

  3825. 

  3826.          !  Interpolate between the layers we have (zhave) and those that we want (zs).
    3827. 

  3827. 

  3828.          z_wantm : DO lwant = 1 , num_soil_layers
    3829. 

  3829.             z_havem : DO lhave = 1 , num_sm_levels_input +2 -1
    3830. 

  3830.                IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    3831. 

  3831.                     ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    3832. 

  3832.                   DO j = jts , MIN(jde-1,jte)
    3833. 

  3833.                      DO i = its , MIN(ide-1,ite)
    3834. 

  3834.                         smois(i,lwant,j)= ( sm_input(i,lhave  ,j) * ( zhave(lhave+1) - zs   (lwant) ) + &
    3835. 

  3835.                                             sm_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    3836. 

  3836.                                                                     ( zhave(lhave+1) - zhave(lhave) )
    3837. 

  3837.                      END DO
    3838. 

  3838.                   END DO
    3839. 

  3839.                   EXIT z_havem
    3840. 

  3840.                END IF
    3841. 

  3841.             END DO z_havem
    3842. 

  3842.          END DO z_wantm
    3843. 

  3843. 

  3844.      ELSE
    3845. 

  3845. 

  3846. !tgs  initialize from RUCLSM data
    3847. 

  3847.          DO l = 1 , num_sm_levels_input
    3848. 

  3848.             zhave(l) = sm_levels_input(l) / 100.
    3849. 

  3849.          END DO
    3850. 

  3850. 

  3851.       !  Interpolate between the layers we have (zhave) and those that we want (zs).
    3852. 

  3852. 

  3853.       z_wantm_2 : DO lwant = 1 , num_soil_layers
    3854. 

  3854.          z_havem_2 : DO lhave = 1 , num_sm_levels_input -1
    3855. 

  3855.             IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    3856. 

  3856.                  ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    3857. 

  3857.                DO j = jts , MIN(jde-1,jte)
    3858. 

  3858.                   DO i = its , MIN(ide-1,ite)
    3859. 

  3859.                      smois(i,lwant,j)= ( sm_input(i,lhave,j ) * ( zhave(lhave+1) - zs   (lwant) ) + &
    3860. 

  3860.                                          sm_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    3861. 

  3861.                                                                  ( zhave(lhave+1) - zhave(lhave) )
    3862. 

  3862.                   END DO
    3863. 

  3863.                END DO
    3864. 

  3864.                EXIT z_havem_2
    3865. 

  3865.              END IF
    3866. 

  3866.          END DO z_havem_2
    3867. 

  3867.       END DO z_wantm_2
    3868. 

  3868. 

  3869.      ENDIF
    3870. 

  3870.          !  Any liquid soil moisture to worry about?
    3871. 

  3871. 

  3872.          IF ( num_sw_levels_input .GT. 1 ) THEN
    3873. 

  3873. 

  3874.             zhave(1) = 0.
    3875. 

  3875.             DO l = 1 , num_sw_levels_input
    3876. 

  3876.                zhave(l+1) = sw_levels_input(l) / 100.
    3877. 

  3877.             END DO
    3878. 

  3878.             zhave(num_sw_levels_input+2) = 300. / 100.
    3879. 

  3879. 

  3880.             !  Interpolate between the layers we have (zhave) and those that we want (zs).
    3881. 

  3881. 

  3882.             z_wantw : DO lwant = 1 , num_soil_layers
    3883. 

  3883.                z_havew : DO lhave = 1 , num_sw_levels_input +2 -1
    3884. 

  3884.                   IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    3885. 

  3885.                        ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    3886. 

  3886.                      DO j = jts , MIN(jde-1,jte)
    3887. 

  3887.                         DO i = its , MIN(ide-1,ite)
    3888. 

  3888.                            sh2o(i,lwant,j)= ( sw_input(i,lhave  ,j) * ( zhave(lhave+1) - zs   (lwant) ) + &
    3889. 

  3889.                                                sw_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    3890. 

  3890.                                                                        ( zhave(lhave+1) - zhave(lhave) )
    3891. 

  3891.                         END DO
    3892. 

  3892.                      END DO
    3893. 

  3893.                      EXIT z_havew
    3894. 

  3894.                   END IF
    3895. 

  3895.                END DO z_havew
    3896. 

  3896.             END DO z_wantw
    3897. 

  3897. 

  3898.          END IF
    3899. 

  3899. 

  3900. 

  3901.          !  Over water, put in reasonable values for soil temperature and moisture.  These won't be
    3902. 

  3902.          !  used, but they will make a more continuous plot.
    3903. 

  3903. 

  3904.          IF ( flag_sst .EQ. 1 ) THEN
    3905. 

  3905.             DO j = jts , MIN(jde-1,jte)
    3906. 

  3906.                DO i = its , MIN(ide-1,ite)
    3907. 

  3907.                   IF ( landmask(i,j) .LT. 0.5 ) THEN
    3908. 

  3908.                      DO l = 1 , num_soil_layers
    3909. 

  3909.                         tslb(i,l,j)= sst(i,j)
    3910. 

  3910. !tgs add line for tsk
    3911. 

  3911.                         tsk(i,j)    = sst(i,j)
    3912. 

  3912.                         smois(i,l,j)= 1.0
    3913. 

  3913.                         sh2o (i,l,j)= 1.0
    3914. 

  3914.                      END DO
    3915. 

  3915.                   END IF
    3916. 

  3916.                END DO
    3917. 

  3917.             END DO
    3918. 

  3918.          ELSE
    3919. 

  3919.             DO j = jts , MIN(jde-1,jte)
    3920. 

  3920.                DO i = its , MIN(ide-1,ite)
    3921. 

  3921.                   IF ( landmask(i,j) .LT. 0.5 ) THEN
    3922. 

  3922.                      DO l = 1 , num_soil_layers
    3923. 

  3923.                         tslb(i,l,j)= tsk(i,j)
    3924. 

  3924.                         smois(i,l,j)= 1.0
    3925. 

  3925.                         sh2o (i,l,j)= 1.0
    3926. 

  3926.                      END DO
    3927. 

  3927.                   END IF
    3928. 

  3928.                END DO
    3929. 

  3929.             END DO
    3930. 

  3930.          END IF
    3931. 

  3931. 

  3932.          DEALLOCATE (zhave)
    3933. 

  3933. 

  3934.       END IF
    3935. 

  3935. 

  3936.    END SUBROUTINE init_soil_2_real
    3937. 

  3937. 

  3938.    SUBROUTINE init_soil_2_ideal ( xland,xice,vegfra,snow,canwat,     &
    3939. 

  3939.                      ivgtyp,isltyp,tslb,smois,tmn,                  &
    3940. 

  3940.                      num_soil_layers,                               &
    3941. 

  3941.                      ids,ide, jds,jde, kds,kde,                     &
    3942. 

  3942.                      ims,ime, jms,jme, kms,kme,                     &
    3943. 

  3943.                      its,ite, jts,jte, kts,kte                      )
    3944. 

  3944. 

  3945.       IMPLICIT NONE
    3946. 

  3946. 

  3947.       INTEGER, INTENT(IN) ::ids,ide, jds,jde, kds,kde,  &
    3948. 

  3948.                             ims,ime, jms,jme, kms,kme,  &
    3949. 

  3949.                             its,ite, jts,jte, kts,kte
    3950. 

  3950. 

  3951.       INTEGER, INTENT(IN) ::num_soil_layers
    3952. 

  3952. 

  3953.       REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , INTENT(OUT) :: smois, tslb
    3954. 

  3954. 

  3955.       REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT)  :: xland, snow, canwat, xice, vegfra, tmn
    3956. 

  3956. 

  3957.       INTEGER, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: ivgtyp, isltyp
    3958. 

  3958. 

  3959.       INTEGER :: icm,jcm,itf,jtf
    3960. 

  3960.       INTEGER ::  i,j,l
    3961. 

  3961. 

  3962.       itf=min0(ite,ide-1)
    3963. 

  3963.       jtf=min0(jte,jde-1)
    3964. 

  3964. 

  3965.       icm = ide/2
    3966. 

  3966.       jcm = jde/2
    3967. 

  3967. 

  3968.       DO j=jts,jtf
    3969. 

  3969.          DO l=1,num_soil_layers
    3970. 

  3970.             DO i=its,itf
    3971. 

  3971. 

  3972.                smois(i,1,j)=0.10
    3973. 

  3973.                smois(i,2,j)=0.10
    3974. 

  3974.                smois(i,3,j)=0.10
    3975. 

  3975.                smois(i,4,j)=0.10
    3976. 

  3976. 

  3977.                tslb(i,1,j)=295.
    3978. 

  3978.                tslb(i,2,j)=297.
    3979. 

  3979.                tslb(i,3,j)=293.
    3980. 

  3980.                tslb(i,4,j)=293.
    3981. 

  3981. 

  3982.             ENDDO
    3983. 

  3983.          ENDDO
    3984. 

  3984.       ENDDO
    3985. 

  3985. 

  3986.       DO j=jts,jtf
    3987. 

  3987.          DO i=its,itf
    3988. 

  3988.             xland(i,j)  =   2
    3989. 

  3989.             tmn(i,j)    = 294.
    3990. 

  3990.             xice(i,j)   =   0.
    3991. 

  3991.             vegfra(i,j) =   0.
    3992. 

  3992.             snow(i,j)   =   0.
    3993. 

  3993.             canwat(i,j) =   0.
    3994. 

  3994.             ivgtyp(i,j) =   7
    3995. 

  3995.             isltyp(i,j) =   8
    3996. 

  3996.          ENDDO
    3997. 

  3997.       ENDDO
    3998. 

  3998. 

  3999.    END SUBROUTINE init_soil_2_ideal
    4000. 

  4000. 

  4001.    SUBROUTINE init_soil_3_real ( tsk , tmn , smois , tslb , &
    4002. 

  4002.                                  st_input , sm_input , landmask, sst, &
    4003. 

  4003.                                  zs , dzs , &
    4004. 

  4004.                                  st_levels_input , sm_levels_input , &
    4005. 

  4005.                                  num_soil_layers , num_st_levels_input , num_sm_levels_input ,  &
    4006. 

  4006.                                  num_st_levels_alloc , num_sm_levels_alloc , &
    4007. 

  4007.                                  flag_sst , flag_soilt000 , flag_soilm000 , &
    4008. 

  4008.                                  ids , ide , jds , jde , kds , kde , &
    4009. 

  4009.                                  ims , ime , jms , jme , kms , kme , &
    4010. 

  4010.                                  its , ite , jts , jte , kts , kte )
    4011. 

  4011. 

  4012.       IMPLICIT NONE
    4013. 

  4013. 

  4014.       INTEGER , INTENT(IN) :: num_soil_layers , &
    4015. 

  4015.                               num_st_levels_input , num_sm_levels_input , &
    4016. 

  4016.                               num_st_levels_alloc , num_sm_levels_alloc , &
    4017. 

  4017.                               ids , ide , jds , jde , kds , kde , &
    4018. 

  4018.                               ims , ime , jms , jme , kms , kme , &
    4019. 

  4019.                               its , ite , jts , jte , kts , kte
    4020. 

  4020. 

  4021.       INTEGER , INTENT(IN) :: flag_sst, flag_soilt000, flag_soilm000
    4022. 

  4022. 

  4023.       INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input
    4024. 

  4024.       INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input
    4025. 

  4025. 

  4026.       REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input
    4027. 

  4027.       REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input
    4028. 

  4028.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst
    4029. 

  4029. 

  4030.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn
    4031. 

  4031.       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk
    4032. 

  4032.       REAL , DIMENSION(num_soil_layers) :: zs , dzs
    4033. 

  4033. 

  4034.       REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois
    4035. 

  4035. 

  4036.       REAL , ALLOCATABLE , DIMENSION(:) :: zhave
    4037. 

  4037. 

  4038.       INTEGER :: i , j , l , lout , lin , lwant , lhave
    4039. 

  4039.       REAL :: temp
    4040. 

  4040. 

  4041.       !  Allocate the soil layer array used for interpolating.
    4042. 

  4042. 

  4043.       IF ( ( num_st_levels_input .LE. 0 ) .OR. &
    4044. 

  4044.            ( num_sm_levels_input .LE. 0 ) ) THEN
    4045. 

  4045.          PRINT '(A)','No input soil level data (either temperature or moisture, or both are missing).  Required for RUC LSM.'
    4046. 

  4046.          CALL wrf_error_fatal ( 'no soil data' )
    4047. 

  4047.       ELSE
    4048. 

  4048.          IF ( flag_soilt000 .eq. 1 ) THEN
    4049. 

  4049.            PRINT '(A)',' Assume RUC LSM 6-level input'
    4050. 

  4050.            ALLOCATE ( zhave( MAX(num_st_levels_input,num_sm_levels_input)  ) )
    4051. 

  4051.          ELSE
    4052. 

  4052.            PRINT '(A)',' Assume non-RUC LSM input'
    4053. 

  4053.            ALLOCATE ( zhave( MAX(num_st_levels_input,num_soil_layers)  ) )
    4054. 

  4054.          END IF
    4055. 

  4055.       END IF
    4056. 

  4056. 

  4057.       !  Sort the levels for temperature.
    4058. 

  4058. 

  4059.       outert : DO lout = 1 , num_st_levels_input-1
    4060. 

  4060.          innert : DO lin = lout+1 , num_st_levels_input
    4061. 

  4061.             IF ( st_levels_input(lout) .GT. st_levels_input(lin) ) THEN
    4062. 

  4062.                temp = st_levels_input(lout)
    4063. 

  4063.                st_levels_input(lout) = st_levels_input(lin)
    4064. 

  4064.                st_levels_input(lin) = NINT(temp)
    4065. 

  4065.                DO j = jts , MIN(jde-1,jte)
    4066. 

  4066.                   DO i = its , MIN(ide-1,ite)
    4067. 

  4067.                      temp = st_input(i,lout,j)
    4068. 

  4068.                      st_input(i,lout,j) = st_input(i,lin,j)
    4069. 

  4069.                      st_input(i,lin,j) = temp
    4070. 

  4070.                   END DO
    4071. 

  4071.                END DO
    4072. 

  4072.             END IF
    4073. 

  4073.          END DO innert
    4074. 

  4074.       END DO outert
    4075. 

  4075. 

  4076.       IF ( flag_soilt000 .NE. 1 ) THEN
    4077. 

  4077.       DO j = jts , MIN(jde-1,jte)
    4078. 

  4078.          DO i = its , MIN(ide-1,ite)
    4079. 

  4079.             st_input(i,1,j) = tsk(i,j)
    4080. 

  4080.             st_input(i,num_st_levels_input+2,j) = tmn(i,j)
    4081. 

  4081.          END DO
    4082. 

  4082.       END DO
    4083. 

  4083.       END IF
    4084. 

  4084. 

  4085.       !  Sort the levels for moisture.
    4086. 

  4086. 

  4087.       outerm: DO lout = 1 , num_sm_levels_input-1
    4088. 

  4088.          innerm : DO lin = lout+1 , num_sm_levels_input
    4089. 

  4089.             IF ( sm_levels_input(lout) .GT. sm_levels_input(lin) ) THEN
    4090. 

  4090.                temp = sm_levels_input(lout)
    4091. 

  4091.                sm_levels_input(lout) = sm_levels_input(lin)
    4092. 

  4092.                sm_levels_input(lin) = NINT(temp)
    4093. 

  4093.                DO j = jts , MIN(jde-1,jte)
    4094. 

  4094.                   DO i = its , MIN(ide-1,ite)
    4095. 

  4095.                      temp = sm_input(i,lout,j)
    4096. 

  4096.                      sm_input(i,lout,j) = sm_input(i,lin,j)
    4097. 

  4097.                      sm_input(i,lin,j) = temp
    4098. 

  4098.                   END DO
    4099. 

  4099.                END DO
    4100. 

  4100.             END IF
    4101. 

  4101.          END DO innerm
    4102. 

  4102.       END DO outerm
    4103. 

  4103. 

  4104.       IF ( flag_soilm000 .NE. 1 ) THEN
    4105. 

  4105.       DO j = jts , MIN(jde-1,jte)
    4106. 

  4106.          DO i = its , MIN(ide-1,ite)
    4107. 

  4107.             sm_input(i,1,j) = sm_input(i,2,j)
    4108. 

  4108.             sm_input(i,num_sm_levels_input+2,j) = sm_input(i,num_sm_levels_input+1,j)
    4109. 

  4109.          END DO
    4110. 

  4110.       END DO
    4111. 

  4111.       END IF
    4112. 

  4112. 

  4113.       !  Here are the levels that we have from the input for temperature.
    4114. 

  4114. 

  4115.       IF ( flag_soilt000 .EQ. 1 ) THEN
    4116. 

  4116.          DO l = 1 , num_st_levels_input
    4117. 

  4117.             zhave(l) = st_levels_input(l) / 100.
    4118. 

  4118.          END DO
    4119. 

  4119. 

  4120.       !  Interpolate between the layers we have (zhave) and those that we want (zs).
    4121. 

  4121. 

  4122.       z_wantt : DO lwant = 1 , num_soil_layers
    4123. 

  4123.          z_havet : DO lhave = 1 , num_st_levels_input -1
    4124. 

  4124.             IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    4125. 

  4125.                  ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    4126. 

  4126.                DO j = jts , MIN(jde-1,jte)
    4127. 

  4127.                   DO i = its , MIN(ide-1,ite)
    4128. 

  4128.                      tslb(i,lwant,j)= ( st_input(i,lhave,j ) * ( zhave(lhave+1) - zs   (lwant) ) + &
    4129. 

  4129.                                         st_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    4130. 

  4130.                                                                 ( zhave(lhave+1) - zhave(lhave) )
    4131. 

  4131.                   END DO
    4132. 

  4132.                END DO
    4133. 

  4133.                EXIT z_havet
    4134. 

  4134.             END IF
    4135. 

  4135.          END DO z_havet
    4136. 

  4136.       END DO z_wantt
    4137. 

  4137. 

  4138.       ELSE
    4139. 

  4139. 

  4140.          zhave(1) = 0.
    4141. 

  4141.          DO l = 1 , num_st_levels_input
    4142. 

  4142.             zhave(l+1) = st_levels_input(l) / 100.
    4143. 

  4143.          END DO
    4144. 

  4144.          zhave(num_st_levels_input+2) = 300. / 100.
    4145. 

  4145. 

  4146.       !  Interpolate between the layers we have (zhave) and those that we want (zs).
    4147. 

  4147. 

  4148.       z_wantt_2 : DO lwant = 1 , num_soil_layers
    4149. 

  4149.          z_havet_2 : DO lhave = 1 , num_st_levels_input +2
    4150. 

  4150.             IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    4151. 

  4151.                  ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    4152. 

  4152.                DO j = jts , MIN(jde-1,jte)
    4153. 

  4153.                   DO i = its , MIN(ide-1,ite)
    4154. 

  4154.                      tslb(i,lwant,j)= ( st_input(i,lhave,j ) * ( zhave(lhave+1) - zs   (lwant) ) + &
    4155. 

  4155.                                         st_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    4156. 

  4156.                                                                 ( zhave(lhave+1) - zhave(lhave) )
    4157. 

  4157.                   END DO
    4158. 

  4158.                END DO
    4159. 

  4159.                EXIT z_havet_2
    4160. 

  4160.             END IF
    4161. 

  4161.          END DO z_havet_2
    4162. 

  4162.       END DO z_wantt_2
    4163. 

  4163. 

  4164.       END IF
    4165. 

  4165. 

  4166.       !  Here are the levels that we have from the input for moisture.
    4167. 

  4167. 

  4168.       IF ( flag_soilm000 .EQ. 1 ) THEN
    4169. 

  4169.          DO l = 1 , num_sm_levels_input
    4170. 

  4170.             zhave(l) = sm_levels_input(l) / 100.
    4171. 

  4171.          END DO
    4172. 

  4172. 

  4173.       !  Interpolate between the layers we have (zhave) and those that we want (zs).
    4174. 

  4174. 

  4175.       z_wantm : DO lwant = 1 , num_soil_layers
    4176. 

  4176.          z_havem : DO lhave = 1 , num_sm_levels_input -1
    4177. 

  4177.             IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    4178. 

  4178.                  ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    4179. 

  4179.                DO j = jts , MIN(jde-1,jte)
    4180. 

  4180.                   DO i = its , MIN(ide-1,ite)
    4181. 

  4181.                      smois(i,lwant,j)= ( sm_input(i,lhave,j ) * ( zhave(lhave+1) - zs   (lwant) ) + &
    4182. 

  4182.                                          sm_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    4183. 

  4183.                                                                  ( zhave(lhave+1) - zhave(lhave) )
    4184. 

  4184.                   END DO
    4185. 

  4185.                END DO
    4186. 

  4186.                EXIT z_havem
    4187. 

  4187.             END IF
    4188. 

  4188.          END DO z_havem
    4189. 

  4189.       END DO z_wantm
    4190. 

  4190. 

  4191.       ELSE
    4192. 

  4192. 

  4193.          zhave(1) = 0.
    4194. 

  4194.          DO l = 1 , num_sm_levels_input
    4195. 

  4195.             zhave(l+1) = sm_levels_input(l) / 100.
    4196. 

  4196.          END DO
    4197. 

  4197.          zhave(num_sm_levels_input+2) = 300. / 100.
    4198. 

  4198. 

  4199.       z_wantm_2 : DO lwant = 1 , num_soil_layers
    4200. 

  4200.          z_havem_2 : DO lhave = 1 , num_sm_levels_input +2
    4201. 

  4201.             IF ( ( zs(lwant) .GE. zhave(lhave  ) ) .AND. &
    4202. 

  4202.                  ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN
    4203. 

  4203.                DO j = jts , MIN(jde-1,jte)
    4204. 

  4204.                   DO i = its , MIN(ide-1,ite)
    4205. 

  4205.                      smois(i,lwant,j)= ( sm_input(i,lhave,j ) * ( zhave(lhave+1) - zs   (lwant) ) + &
    4206. 

  4206.                                          sm_input(i,lhave+1,j) * ( zs   (lwant  ) - zhave(lhave) ) ) / &
    4207. 

  4207.                                                                  ( zhave(lhave+1) - zhave(lhave) )
    4208. 

  4208.                   END DO
    4209. 

  4209.                END DO
    4210. 

  4210.                EXIT z_havem_2
    4211. 

  4211.             END IF
    4212. 

  4212.          END DO z_havem_2
    4213. 

  4213.       END DO z_wantm_2
    4214. 

  4214. 

  4215.       END IF
    4216. 

  4216.       !  Over water, put in reasonable values for soil temperature and moisture.  These won't be
    4217. 

  4217.       !  used, but they will make a more continuous plot.
    4218. 

  4218. 

  4219.       IF ( flag_sst .EQ. 1 ) THEN
    4220. 

  4220.          DO j = jts , MIN(jde-1,jte)
    4221. 

  4221.             DO i = its , MIN(ide-1,ite)
    4222. 

  4222.                IF ( landmask(i,j) .LT. 0.5 ) THEN
    4223. 

  4223.                   DO l = 1 , num_soil_layers
    4224. 

  4224.                      tslb(i,l,j) = sst(i,j)
    4225. 

  4225.                      tsk(i,j)    = sst(i,j)
    4226. 

  4226.                      smois(i,l,j)= 1.0
    4227. 

  4227.                   END DO
    4228. 

  4228.                END IF
    4229. 

  4229.             END DO
    4230. 

  4230.          END DO
    4231. 

  4231.       ELSE
    4232. 

  4232.          DO j = jts , MIN(jde-1,jte)
    4233. 

  4233.             DO i = its , MIN(ide-1,ite)
    4234. 

  4234.                IF ( landmask(i,j) .LT. 0.5 ) THEN
    4235. 

  4235.                   DO l = 1 , num_soil_layers
    4236. 

  4236.                      tslb(i,l,j)= tsk(i,j)
    4237. 

  4237.                      smois(i,l,j)= 1.0
    4238. 

  4238.                   END DO
    4239. 

  4239.                END IF
    4240. 

  4240.             END DO
    4241. 

  4241.          END DO
    4242. 

  4242.       END IF
    4243. 

  4243. 

  4244.       DEALLOCATE (zhave)
    4245. 

  4245. 

  4246.    END SUBROUTINE init_soil_3_real
    4247. 

  4247. 

  4248. END MODULE module_soil_pre
    4249. 

  4249. 

  4250. #endif
    4251. 

  4251.