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

/wrfv2_fire/dyn_nmm/module_initialize_real.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 5238 lines | 3350 code | 960 blank | 928 comment | 103 complexity | 132c80bdb132b364e3d5f3f4a821dd15 MD5 | raw file
Possible License(s): AGPL-1.0

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

    

  1. !REAL:MODEL_LAYER:INITIALIZATION
    2. 

  2. 

  3. !  This MODULE holds the routines which are used to perform various initializations
    4. 

  4. !  for individual domains utilizing the NMM dynamical core.
    5. 

  5. 

  6. !-----------------------------------------------------------------------
    7. 

  7. 

  8. MODULE module_initialize_real
    9. 

  9. 

  10.    USE module_bc
    11. 

  11.    USE module_configure
    12. 

  12.    USE module_domain
    13. 

  13.    USE module_io_domain
    14. 

  14.    USE module_model_constants
    15. 

  15. !   USE module_si_io_nmm
    16. 

  16.    USE module_state_description
    17. 

  17.    USE module_timing
    18. 

  18.    USE module_soil_pre
    19. 

  19. #ifdef DM_PARALLEL
    20. 

  20.    USE module_dm,                    ONLY : LOCAL_COMMUNICATOR       &
    21. 

  21.                                            ,MYTASK,NTASKS,NTASKS_X   &
    22. 

  22.                                            ,NTASKS_Y
    23. 

  23.    USE module_comm_dm
    24. 

  24.    USE module_ext_internal
    25. 

  25. #endif
    26. 

  26. 

  27.    INTEGER :: internal_time_loop
    28. 

  28.    INTEGER:: MPI_COMM_COMP,MYPE
    29. 

  29.    INTEGER:: loopinc, iloopinc
    30. 

  30. 

  31. CONTAINS
    32. 

  32. 

  33. !-------------------------------------------------------------------
    34. 

  34. 

  35.    SUBROUTINE init_domain ( grid )
    36. 

  36. 

  37.       IMPLICIT NONE
    38. 

  38. 

  39.       !  Input space and data.  No gridded meteorological data has been stored, though.
    40. 

  40. 

  41. !     TYPE (domain), POINTER :: grid
    42. 

  42.       TYPE (domain)          :: grid
    43. 

  43. 

  44.       !  Local data.
    45. 

  45. 

  46.       INTEGER :: idum1, idum2
    47. 

  47. 

  48.       CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
    49. 

  49. 

  50.         CALL init_domain_nmm (grid &
    51. 

  51. !
    52. 

  52. #include <actual_new_args.inc>
    53. 

  53. !
    54. 

  54.       )
    55. 

  55. 

  56.    END SUBROUTINE init_domain
    57. 

  57. 

  58. !-------------------------------------------------------------------
    59. 

  59. !---------------------------------------------------------------------
    60. 

  60.    SUBROUTINE init_domain_nmm ( grid &
    61. 

  61. !
    62. 

  62. # include <dummy_new_args.inc>
    63. 

  63. !
    64. 

  64.    )
    65. 

  65. 

  66.       USE module_optional_input
    67. 

  67.       IMPLICIT NONE
    68. 

  68. 

  69.       !  Input space and data.  No gridded meteorological data has been stored, though.
    70. 

  70. 

  71. !     TYPE (domain), POINTER :: grid
    72. 

  72.       TYPE (domain)          :: grid
    73. 

  73. 

  74. # include <dummy_new_decl.inc>
    75. 

  75. 

  76.       TYPE (grid_config_rec_type)              :: config_flags
    77. 

  77. 

  78.       !  Local domain indices and counters.
    79. 

  79. 

  80.       INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
    81. 

  81. 

  82.       INTEGER                             ::                       &
    83. 

  83.                                      ids, ide, jds, jde, kds, kde, &
    84. 

  84.                                      ims, ime, jms, jme, kms, kme, &
    85. 

  85.                                      its, ite, jts, jte, kts, kte, &
    86. 

  86.                                      ips, ipe, jps, jpe, kps, kpe, &
    87. 

  87.                                      i, j, k, NNXP, NNYP
    88. 

  88. 

  89.       !  Local data
    90. 

  90. 

  91.         CHARACTER(LEN=19):: start_date
    92. 

  92. 

  93. #ifdef DM_PARALLEL
    94. 

  94. 

  95.         LOGICAL,EXTERNAL :: WRF_DM_ON_MONITOR
    96. 

  96.        logical :: test
    97. 

  97. 

  98. !              INTEGER :: DOMDESC
    99. 

  99.               REAL,ALLOCATABLE    :: SICE_G(:,:), SM_G(:,:)
    100. 

  100.               INTEGER, ALLOCATABLE::  IHE_G(:),IHW_G(:)
    101. 

  101.               INTEGER, ALLOCATABLE::  ITEMP(:,:)
    102. 

  102.               INTEGER :: my_e,my_n,my_s,my_w,my_ne,my_nw,my_se,my_sw,myi,myj,npe
    103. 

  103.               INTEGER :: istat,inpes,jnpes
    104. 

  104. #else
    105. 

  105.         integer, allocatable:: ihw(:),ihe(:)
    106. 

  106. #endif
    107. 

  107. 

  108. 

  109.       CHARACTER (LEN=255) :: message
    110. 

  110. 

  111.       INTEGER :: error
    112. 

  112.       REAL    :: p_surf, p_level
    113. 

  113.       REAL    :: cof1, cof2
    114. 

  114.       REAL    :: qvf , qvf1 , qvf2 , pd_surf
    115. 

  115.       REAL    :: p00 , t00 , a
    116. 

  116.       REAL    :: hold_znw, rmin,rmax
    117. 

  117. 

  118.       REAL :: p_top_requested , ptsgm
    119. 

  119.       INTEGER :: num_metgrid_levels, ICOUNT
    120. 

  120.       REAL , DIMENSION(max_eta) :: eta_levels
    121. 

  121. 

  122.       LOGICAL :: stretch_grid, dry_sounding, debug, log_flag_sst, hyb_coor
    123. 

  123. 

  124.         REAL, ALLOCATABLE,DIMENSION(:,:):: ADUM2D,SNOWC,HT,TG_ALT, &
    125. 

  125.                                            PDVP,PSFC_OUTV
    126. 

  126. 

  127.         REAL, ALLOCATABLE,DIMENSION(:,:,:):: P3D_OUT,P3DV_OUT,P3DV_IN, &
    128. 

  128.                                              QTMP,QTMP2
    129. 

  129. 

  130.         INTEGER, ALLOCATABLE, DIMENSION(:):: KHL2,KVL2,KHH2,KVH2, &
    131. 

  131.                                              KHLA,KHHA,KVLA,KVHA
    132. 

  132. 

  133. !        INTEGER, ALLOCATABLE, DIMENSION(:,:):: grid%lu_index
    134. 

  134. 

  135.         REAL, ALLOCATABLE, DIMENSION(:):: DXJ,WPDARJ,CPGFUJ,CURVJ, &
    136. 

  136.                                           FCPJ,FDIVJ,EMJ,EMTJ,FADJ, &
    137. 

  137.                                           HDACJ,DDMPUJ,DDMPVJ
    138. 

  138. 

  139.         REAL, ALLOCATABLE,DIMENSION(:),SAVE:: SG1,SG2,DSG1,DSG2, &
    140. 

  140.                                               SGML1,SGML2
    141. 

  141. 

  142. !-- Carsel and Parrish [1988]
    143. 

  143.          REAL , DIMENSION(100) :: lqmi
    144. 

  144.          integer iicount
    145. 

  145. 

  146.         REAL:: TPH0D,TLM0D
    147. 

  147.         REAL:: TPH0,WB,SB,TDLM,TDPH
    148. 

  148.         REAL:: WBI,SBI,EBI,ANBI,STPH0,CTPH0
    149. 

  149.         REAL:: TSPH,DTAD,DTCF
    150. 

  150.         REAL:: ACDT,CDDAMP,DXP,FP
    151. 

  151.         REAL:: WBD,SBD
    152. 

  152.         REAL:: RSNOW,SNOFAC
    153. 

  153.         REAL, PARAMETER:: SALP=2.60
    154. 

  154.         REAL, PARAMETER:: SNUP=0.040
    155. 

  155.         REAL:: SMCSUM,STCSUM,SEAICESUM,FISX
    156. 

  156.         REAL:: cur_smc, aposs_smc
    157. 

  157. 

  158.         REAL:: COAC, CODAMP
    159. 

  159. 

  160.         INTEGER,PARAMETER:: DOUBLE=SELECTED_REAL_KIND(15,300)
    161. 

  161.         REAL(KIND=DOUBLE):: TERM1,APH,TLM,TPH,DLM,DPH,STPH,CTPH
    162. 

  162. 

  163.         INTEGER:: KHH,KVH,JAM,JA, IHL, IHH, L
    164. 

  164.         INTEGER:: II,JJ,ISRCH,ISUM,ITER,Ilook,Jlook
    165. 

  165. 

  166.         REAL, PARAMETER:: DTR=0.01745329
    167. 

  167.         REAL, PARAMETER:: W_NMM=0.08
    168. 

  168. #if defined(HWRF)
    169. 

  169.         REAL, PARAMETER:: DDFC=1.0
    170. 

  170. #else
    171. 

  171.         REAL, PARAMETER:: DDFC=8.0
    172. 

  172. #endif
    173. 

  173.         REAL, PARAMETER:: TWOM=.00014584
    174. 

  174.         REAL, PARAMETER:: CP=1004.6
    175. 

  175.         REAL, PARAMETER:: DFC=1.0
    176. 

  176.         REAL, PARAMETER:: ROI=916.6
    177. 

  177.         REAL, PARAMETER:: R=287.04
    178. 

  178.         REAL, PARAMETER:: CI=2060.0
    179. 

  179.         REAL, PARAMETER:: ROS=1500.
    180. 

  180.         REAL, PARAMETER:: CS=1339.2
    181. 

  181.         REAL, PARAMETER:: DS=0.050
    182. 

  182.         REAL, PARAMETER:: AKS=.0000005
    183. 

  183.         REAL, PARAMETER:: DZG=2.85
    184. 

  184.         REAL, PARAMETER:: DI=.1000
    185. 

  185.         REAL, PARAMETER:: AKI=0.000001075
    186. 

  186.         REAL, PARAMETER:: DZI=2.0
    187. 

  187.         REAL, PARAMETER:: THL=210.
    188. 

  188.         REAL, PARAMETER:: PLQ=70000.
    189. 

  189.         REAL, PARAMETER:: ERAD=6371200.
    190. 

  190.         REAL, PARAMETER:: TG0=258.16
    191. 

  191.         REAL, PARAMETER:: TGA=30.0
    192. 

  192.     integer :: numzero,numexamined
    193. 

  193. #ifdef HWRF
    194. 

  194. !============================================================================
    195. 

  195. !   gopal's doing for ocean coupling
    196. 

  196. !============================================================================
    197. 

  197. 

  198.  REAL, DIMENSION(:,:),    ALLOCATABLE :: NHLAT,NHLON,NVLAT,NVLON,HRES_SM
    199. 

  199.  REAL                                 :: NDLMD,NDPHD,NWBD,NSBD
    200. 

  200.  INTEGER                              :: NIDE,NJDE,ILOC,JLOC
    201. 

  201. 

  202.       INTEGER fid, ierr, nprocs
    203. 

  203.       CHARACTER*255 f65name, SysString
    204. 

  204. 

  205. !============================================================================
    206. 

  206. ! end gopal's doing for ocean coupling
    207. 

  207. !============================================================================
    208. 

  208. #endif
    209. 

  209. 

  210.         if (ALLOCATED(ADUM2D)) DEALLOCATE(ADUM2D)
    211. 

  211.         if (ALLOCATED(TG_ALT)) DEALLOCATE(TG_ALT)
    212. 

  212. 

  213. !#define COPY_IN
    214. 

  214. !#include <scalar_derefs.inc>
    215. 

  215. #ifdef DM_PARALLEL
    216. 

  216. #    include <data_calls.inc>
    217. 

  217. #endif
    218. 

  218. 

  219.       SELECT CASE ( model_data_order )
    220. 

  220.          CASE ( DATA_ORDER_ZXY )
    221. 

  221.             kds = grid%sd31 ; kde = grid%ed31 ;
    222. 

  222.             ids = grid%sd32 ; ide = grid%ed32 ;
    223. 

  223.             jds = grid%sd33 ; jde = grid%ed33 ;
    224. 

  224. 

  225.             kms = grid%sm31 ; kme = grid%em31 ;
    226. 

  226.             ims = grid%sm32 ; ime = grid%em32 ;
    227. 

  227.             jms = grid%sm33 ; jme = grid%em33 ;
    228. 

  228. 

  229.             kts = grid%sp31 ; kte = grid%ep31 ; ! tile is entire patch
    230. 

  230.             its = grid%sp32 ; ite = grid%ep32 ; ! tile is entire patch
    231. 

  231.             jts = grid%sp33 ; jte = grid%ep33 ; ! tile is entire patch
    232. 

  232. 

  233.          CASE ( DATA_ORDER_XYZ )
    234. 

  234.             ids = grid%sd31 ; ide = grid%ed31 ;
    235. 

  235.             jds = grid%sd32 ; jde = grid%ed32 ;
    236. 

  236.             kds = grid%sd33 ; kde = grid%ed33 ;
    237. 

  237. 

  238.             ims = grid%sm31 ; ime = grid%em31 ;
    239. 

  239.             jms = grid%sm32 ; jme = grid%em32 ;
    240. 

  240.             kms = grid%sm33 ; kme = grid%em33 ;
    241. 

  241. 

  242.             its = grid%sp31 ; ite = grid%ep31 ; ! tile is entire patch
    243. 

  243.             jts = grid%sp32 ; jte = grid%ep32 ; ! tile is entire patch
    244. 

  244.             kts = grid%sp33 ; kte = grid%ep33 ; ! tile is entire patch
    245. 

  245. 

  246.          CASE ( DATA_ORDER_XZY )
    247. 

  247.             ids = grid%sd31 ; ide = grid%ed31 ;
    248. 

  248.             kds = grid%sd32 ; kde = grid%ed32 ;
    249. 

  249.             jds = grid%sd33 ; jde = grid%ed33 ;
    250. 

  250. 

  251.             ims = grid%sm31 ; ime = grid%em31 ;
    252. 

  252.             kms = grid%sm32 ; kme = grid%em32 ;
    253. 

  253.             jms = grid%sm33 ; jme = grid%em33 ;
    254. 

  254. 

  255.             its = grid%sp31 ; ite = grid%ep31 ; ! tile is entire patch
    256. 

  256.             kts = grid%sp32 ; kte = grid%ep32 ; ! tile is entire patch
    257. 

  257.             jts = grid%sp33 ; jte = grid%ep33 ; ! tile is entire patch
    258. 

  258. 

  259.       END SELECT
    260. 

  260. 

  261. #ifdef DM_PARALLEL
    262. 

  262.       CALL WRF_GET_MYPROC(MYPE)
    263. 

  263.       CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
    264. 

  264.       call wrf_get_nprocx(inpes)
    265. 

  265.       call wrf_get_nprocy(jnpes)
    266. 

  266. !
    267. 

  267.       allocate(itemp(inpes,jnpes),stat=istat)
    268. 

  268.       npe=0
    269. 

  269. !
    270. 

  270.       do j=1,jnpes
    271. 

  271.       do i=1,inpes
    272. 

  272.         itemp(i,j)=npe
    273. 

  273.         if(npe==mype)then
    274. 

  274.           myi=i
    275. 

  275.           myj=j
    276. 

  276.         endif
    277. 

  277.         npe=npe+1
    278. 

  278.       enddo
    279. 

  279.       enddo
    280. 

  280. !
    281. 

  281.       my_n=-1
    282. 

  282.       if(myj+1<=jnpes)my_n=itemp(myi,myj+1)
    283. 

  283. !
    284. 

  284.       my_e=-1
    285. 

  285.       if(myi+1<=inpes)my_e=itemp(myi+1,myj)
    286. 

  286. !
    287. 

  287.       my_s=-1
    288. 

  288.       if(myj-1>=1)my_s=itemp(myi,myj-1)
    289. 

  289. !
    290. 

  290.       my_w=-1
    291. 

  291.       if(myi-1>=1)my_w=itemp(myi-1,myj)
    292. 

  292. !
    293. 

  293.       my_ne=-1
    294. 

  294.       if((myi+1<=inpes).and.(myj+1<=jnpes)) &
    295. 

  295.          my_ne=itemp(myi+1,myj+1)
    296. 

  296. !
    297. 

  297.       my_se=-1
    298. 

  298.       if((myi+1<=inpes).and.(myj-1>=1)) &
    299. 

  299.          my_se=itemp(myi+1,myj-1)
    300. 

  300. !
    301. 

  301.       my_sw=-1
    302. 

  302.       if((myi-1>=1).and.(myj-1>=1)) &
    303. 

  303.          my_sw=itemp(myi-1,myj-1)
    304. 

  304. !
    305. 

  305.       my_nw=-1
    306. 

  306.       if((myi-1>=1).and.(myj+1<=jnpes)) &
    307. 

  307.          my_nw=itemp(myi-1,myj+1)
    308. 

  308. !
    309. 

  309. !     my_neb(1)=my_n
    310. 

  310. !     my_neb(2)=my_e
    311. 

  311. !     my_neb(3)=my_s
    312. 

  312. !     my_neb(4)=my_w
    313. 

  313. !     my_neb(5)=my_ne
    314. 

  314. !     my_neb(6)=my_se
    315. 

  315. !     my_neb(7)=my_sw
    316. 

  316. !     my_neb(8)=my_nw
    317. 

  317. !
    318. 

  318.       deallocate(itemp)
    319. 

  319. #endif
    320. 

  320. 

  321.         NNXP=min(ITE,IDE-1)
    322. 

  322.         NNYP=min(JTE,JDE-1)
    323. 

  323. 

  324.         write(message,*) 'IDE, JDE: ', IDE,JDE
    325. 

  325.         write(message,*) 'NNXP, NNYP: ', NNXP,NNYP
    326. 

  326.         CALL wrf_message(message)
    327. 

  327. 

  328.         JAM=6+2*(JDE-JDS-10)
    329. 

  329. 

  330.         if (internal_time_loop .eq. 1) then
    331. 

  331.           ALLOCATE(ADUM2D(grid%sm31:grid%em31,jms:jme))
    332. 

  332.           ALLOCATE(KHL2(JTS:NNYP),KVL2(JTS:NNYP),KHH2(JTS:NNYP),KVH2(JTS:NNYP))
    333. 

  333.           ALLOCATE(DXJ(JTS:NNYP),WPDARJ(JTS:NNYP),CPGFUJ(JTS:NNYP),CURVJ(JTS:NNYP))
    334. 

  334.           ALLOCATE(FCPJ(JTS:NNYP),FDIVJ(JTS:NNYP),&
    335. 

  335.                    FADJ(JTS:NNYP))
    336. 

  336.           ALLOCATE(HDACJ(JTS:NNYP),DDMPUJ(JTS:NNYP),DDMPVJ(JTS:NNYP))
    337. 

  337.           ALLOCATE(KHLA(JAM),KHHA(JAM))
    338. 

  338.           ALLOCATE(KVLA(JAM),KVHA(JAM))
    339. 

  339.         endif
    340. 

  340. 

  341. 

  342.     CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
    343. 

  343. 

  344.        IF ( CONFIG_FLAGS%FRACTIONAL_SEAICE == 1 ) THEN
    345. 

  345.           CALL WRF_ERROR_FATAL("NMM cannot use FRACTIONAL_SEAICE = 1")
    346. 

  346.        ENDIF
    347. 

  347. 

  348.       if ( config_flags%bl_pbl_physics == BOULACSCHEME ) then
    349. 

  349.          call wrf_error_fatal("Cannot use BOULAC PBL with NMM")
    350. 

  350.       endif
    351. 

  351. 

  352.         write(message,*) 'cen_lat: ', config_flags%cen_lat
    353. 

  353.         CALL wrf_debug(100,message)
    354. 

  354.         write(message,*) 'cen_lon: ', config_flags%cen_lon
    355. 

  355.         CALL wrf_debug(100,message)
    356. 

  356.         write(message,*) 'dx: ', config_flags%dx
    357. 

  357.         CALL wrf_debug(100,message)
    358. 

  358.         write(message,*) 'dy: ', config_flags%dy
    359. 

  359.         CALL wrf_debug(100,message)
    360. 

  360.         write(message,*) 'config_flags%start_year: ', config_flags%start_year
    361. 

  361.         CALL wrf_debug(100,message)
    362. 

  362.         write(message,*) 'config_flags%start_month: ', config_flags%start_month
    363. 

  363.         CALL wrf_debug(100,message)
    364. 

  364.         write(message,*) 'config_flags%start_day: ', config_flags%start_day
    365. 

  365.         CALL wrf_debug(100,message)
    366. 

  366.         write(message,*) 'config_flags%start_hour: ', config_flags%start_hour
    367. 

  367.         CALL wrf_debug(100,message)
    368. 

  368. 

  369.         write(start_date,435) config_flags%start_year, config_flags%start_month, &
    370. 

  370.                 config_flags%start_day, config_flags%start_hour
    371. 

  371.   435   format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':00:00')
    372. 

  372. 

  373.         grid%dlmd=config_flags%dx
    374. 

  374.         grid%dphd=config_flags%dy
    375. 

  375.         tph0d=config_flags%cen_lat
    376. 

  376.         tlm0d=config_flags%cen_lon
    377. 

  377. 

  378. !==========================================================================
    379. 

  379. 

  380. !!
    381. 

  381. 

  382.  !  Check to see if the boundary conditions are set
    383. 

  383.  !  properly in the namelist file.
    384. 

  384.  !  This checks for sufficiency and redundancy.
    385. 

  385. 

  386.       CALL boundary_condition_check( config_flags, bdyzone, error, grid%id )
    387. 

  387. 

  388.       !  Some sort of "this is the first time" initialization.  Who knows.
    389. 

  389. 

  390.       grid%itimestep=0
    391. 

  391. 

  392.       !  Pull in the info in the namelist to compare it to the input data.
    393. 

  393. 

  394.       grid%real_data_init_type = model_config_rec%real_data_init_type
    395. 

  395.       write(message,*) 'what is flag_metgrid: ', flag_metgrid
    396. 

  396.       CALL wrf_message(message)
    397. 

  397. 

  398.      IF ( flag_metgrid .EQ. 1 ) THEN  !   <----- START OF VERTICAL INTERPOLATION PART ---->
    399. 

  399. 

  400.      num_metgrid_levels = grid%num_metgrid_levels
    401. 

  401. 

  402. 

  403. 	IF (grid%ght_gc(its,jts,num_metgrid_levels/2) .lt. grid%ght_gc(its,jts,num_metgrid_levels/2+1)) THEN
    404. 

  404. 

  405.            write(message,*) 'normal ground up file order'
    406. 

  406.            hyb_coor=.false.
    407. 

  407.            CALL wrf_message(message)
    408. 

  408. 

  409.         ELSE
    410. 

  410. 

  411.            hyb_coor=.true.
    412. 

  412.            write(message,*) 'reverse the order of coordinate'
    413. 

  413.            CALL wrf_message(message)
    414. 

  414. 

  415.            CALL reverse_vert_coord(grid%ght_gc, 2, num_metgrid_levels &
    416. 

  416.      &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
    417. 

  417.      &,                            IMS,IME,JMS,JME,KMS,KME        &
    418. 

  418.      &,                            ITS,ITE,JTS,JTE,KTS,KTE )
    419. 

  419. 

  420. #if defined(HWRF)
    421. 

  421.           if(.not. grid%use_prep_hybrid) then
    422. 

  422. #endif
    423. 

  423. 

  424.            CALL reverse_vert_coord(grid%p_gc, 2, num_metgrid_levels &
    425. 

  425.      &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
    426. 

  426.      &,                            IMS,IME,JMS,JME,KMS,KME        &
    427. 

  427.      &,                            ITS,ITE,JTS,JTE,KTS,KTE )
    428. 

  428. 

  429.            CALL reverse_vert_coord(grid%t_gc, 2, num_metgrid_levels &
    430. 

  430.      &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
    431. 

  431.      &,                            IMS,IME,JMS,JME,KMS,KME        &
    432. 

  432.      &,                            ITS,ITE,JTS,JTE,KTS,KTE )
    433. 

  433. 

  434.            CALL reverse_vert_coord(grid%u_gc, 2, num_metgrid_levels &
    435. 

  435.      &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
    436. 

  436.      &,                            IMS,IME,JMS,JME,KMS,KME        &
    437. 

  437.      &,                            ITS,ITE,JTS,JTE,KTS,KTE )
    438. 

  438. 

  439.            CALL reverse_vert_coord(grid%v_gc, 2, num_metgrid_levels &
    440. 

  440.      &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
    441. 

  441.      &,                            IMS,IME,JMS,JME,KMS,KME        &
    442. 

  442.      &,                            ITS,ITE,JTS,JTE,KTS,KTE )
    443. 

  443. 

  444.            CALL reverse_vert_coord(grid%rh_gc, 2, num_metgrid_levels &
    445. 

  445.      &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
    446. 

  446.      &,                            IMS,IME,JMS,JME,KMS,KME        &
    447. 

  447.      &,                            ITS,ITE,JTS,JTE,KTS,KTE )
    448. 

  448. 

  449. #if defined(HWRF)
    450. 

  450.           endif
    451. 

  451. #endif
    452. 

  452. 

  453.         endif
    454. 

  454. 

  455. 

  456.         IF (hyb_coor) THEN
    457. 

  457.                            ! limit extreme deviations from source model topography
    458. 

  458.                            ! due to potential for nasty extrapolation/interpolation issues
    459. 

  459.                            !
    460. 

  460.           write(message,*) 'min, max of grid%ht_gc before adjust: ', minval(grid%ht_gc), maxval(grid%ht_gc)
    461. 

  461.           CALL wrf_debug(100,message)
    462. 

  462.           ICOUNT=0
    463. 

  463.           DO J=JTS,min(JTE,JDE-1)
    464. 

  464.            DO I=ITS,min(ITE,IDE-1)
    465. 

  465.              IF ((grid%ht_gc(I,J) - grid%ght_gc(I,J,2)) .LT. -150.) THEN
    466. 

  466.                grid%ht_gc(I,J)=grid%ght_gc(I,J,2)-150.
    467. 

  467.                IF (ICOUNT .LT. 20) THEN
    468. 

  468.                  write(message,*) 'increasing NMM topo toward RUC  ', I,J
    469. 

  469.                  CALL wrf_debug(100,message)
    470. 

  470.                  ICOUNT=ICOUNT+1
    471. 

  471.                ENDIF
    472. 

  472.              ELSEIF ((grid%ht_gc(I,J) - grid%ght_gc(I,J,2)) .GT. 150.) THEN
    473. 

  473.                grid%ht_gc(I,J)=grid%ght_gc(I,J,2)+150.
    474. 

  474.                IF (ICOUNT .LT. 20) THEN
    475. 

  475.                  write(message,*) 'decreasing NMM topo toward RUC ', I,J
    476. 

  476.                  CALL wrf_debug(100,message)
    477. 

  477.                  ICOUNT=ICOUNT+1
    478. 

  478.                ENDIF
    479. 

  479.              ENDIF
    480. 

  480.            END DO
    481. 

  481.           END DO
    482. 

  482. 

  483.           write(message,*) 'min, max of ht_gc after correct: ', minval(grid%ht_gc), maxval(grid%ht_gc)
    484. 

  484.           CALL wrf_debug(100,message)
    485. 

  485.         ENDIF
    486. 

  486. 

  487.       CALL boundary_smooth(grid%ht_gc,grid%landmask, grid, 12 , 12 &
    488. 

  488.      &,                          IDS,IDE,JDS,JDE,KDS,KDE             &
    489. 

  489.      &,                          IMS,IME,JMS,JME,KMS,KME             &
    490. 

  490.      &,                          ITS,ITE,JTS,JTE,KTS,KTE )
    491. 

  491. 

  492.        DO j = jts, MIN(jte,jde-1)
    493. 

  493.          DO i = its, MIN(ite,ide-1)
    494. 

  494.            if (grid%landmask(I,J) .gt. 0.5) grid%sm(I,J)=0.
    495. 

  495.            if (grid%landmask(I,J) .le. 0.5) grid%sm(I,J)=1.
    496. 

  496.         if (grid%tsk_gc(I,J) .gt. 0.) then
    497. 

  497.            grid%nmm_tsk(I,J)=grid%tsk_gc(I,J)
    498. 

  498.         else
    499. 

  499. #if defined(HWRF)
    500. 

  500.                 if(grid%use_prep_hybrid) then
    501. 

  501.                    if(grid%t(I,J,1)<100) then
    502. 

  502.                       write(*,*) 'NO VALID SURFACE TEMPERATURE: I,J,TSK_GC(I,J),T(I,J,1) = ', &
    503. 

  503.                            I,J,grid%TSK_GC(I,J),grid%T(I,J,1)
    504. 

  504.                    else
    505. 

  505.                       grid%nmm_tsk(I,J)=grid%t(I,J,1) ! stopgap measure
    506. 

  506.                    end if
    507. 

  507.                 else
    508. 

  508. #endif
    509. 

  509.            grid%nmm_tsk(I,J)=grid%t_gc(I,J,1) ! stopgap measure
    510. 

  510. #if defined(HWRF)
    511. 

  511.                 endif
    512. 

  512. #endif
    513. 

  513.         endif
    514. 

  514. !
    515. 

  515.            grid%glat(I,J)=grid%hlat_gc(I,J)*DEGRAD
    516. 

  516.            grid%glon(I,J)=grid%hlon_gc(I,J)*DEGRAD
    517. 

  517.            grid%weasd(I,J)=grid%snow(I,J)
    518. 

  518.            grid%xice(I,J)=grid%xice_gc(I,J)
    519. 

  519.          ENDDO
    520. 

  520.        ENDDO
    521. 

  521. ! First item is to define the target vertical coordinate
    522. 

  522. 

  523.      num_metgrid_levels = grid%num_metgrid_levels
    524. 

  524.      eta_levels(1:kde) = model_config_rec%eta_levels(1:kde)
    525. 

  525.      ptsgm             = model_config_rec%ptsgm
    526. 

  526.      p_top_requested = grid%p_top_requested
    527. 

  527.      grid%pt=p_top_requested
    528. 

  528. 

  529.         if (internal_time_loop .eq. 1) then
    530. 

  530. 

  531.         if (eta_levels(1) .ne. 1.0) then
    532. 

  532. #if defined(HWRF)
    533. 

  533.              if(grid%use_prep_hybrid) then
    534. 

  534.                 call wrf_error_fatal('PREP_HYBRID ERROR: eta_levels is not specified, but use_prep_hybrid=.true.')
    535. 

  535.              end if
    536. 

  536. #endif
    537. 

  537. 

  538.           write(message,*) '********************************************************************* '
    539. 

  539.           CALL wrf_message(message)
    540. 

  540.           write(message,*) '**  eta_levels appears not to be specified in the namelist'
    541. 

  541.           CALL wrf_message(message)
    542. 

  542.           write(message,*) '**  We will call compute_nmm_levels to define layer thicknesses.'
    543. 

  543.           CALL wrf_message(message)
    544. 

  544.           write(message,*) '**  These levels should be reasonable for running the model, '
    545. 

  545.           CALL wrf_message(message)
    546. 

  546.           write(message,*) '**  but may not be ideal for the simulation being made.  Consider   '
    547. 

  547.           CALL wrf_message(message)
    548. 

  548.           write(message,*) '**  defining your own levels by specifying eta_levels in the model   '
    549. 

  549.           CALL wrf_message(message)
    550. 

  550.           write(message,*) '**  namelist. '
    551. 

  551.           CALL wrf_message(message)
    552. 

  552.           write(message,*) '********************************************************************** '
    553. 

  553.           CALL wrf_message(message)
    554. 

  554. 

  555.           CALL compute_nmm_levels(KDE,p_top_requested,eta_levels)
    556. 

  556. 

  557.           DO L=1,KDE
    558. 

  558.             write(message,*) 'L, eta_levels(L) returned :: ', L,eta_levels(L)
    559. 

  559.             CALL wrf_message(message)
    560. 

  560.           ENDDO
    561. 

  561. 

  562.         endif
    563. 

  563. 

  564.         write(message,*) 'KDE-1: ', KDE-1
    565. 

  565.         CALL wrf_debug(1,message)
    566. 

  566.         allocate(SG1(1:KDE-1))
    567. 

  567.         allocate(SG2(1:KDE-1))
    568. 

  568.         allocate(DSG1(1:KDE-1))
    569. 

  569.         allocate(DSG2(1:KDE-1))
    570. 

  570.         allocate(SGML1(1:KDE))
    571. 

  571.         allocate(SGML2(1:KDE))
    572. 

  572. 

  573.       CALL define_nmm_vertical_coord (kde-1, ptsgm, grid%pt,grid%pdtop, eta_levels, &
    574. 

  574.                                       grid%eta1,grid%deta1,grid%aeta1,             &
    575. 

  575.                                       grid%eta2,grid%deta2,grid%aeta2, grid%dfl, grid%dfrlg         )
    576. 

  576. 

  577.        DO L=KDS,KDE-1
    578. 

  578.         grid%deta(L)=eta_levels(L)-eta_levels(L+1)
    579. 

  579.        ENDDO
    580. 

  580.         endif
    581. 

  581. 

  582.         write(message,*) 'num_metgrid_levels: ', num_metgrid_levels
    583. 

  583.         CALL wrf_message(message)
    584. 

  584. 

  585.        DO j = jts, MIN(jte,jde-1)
    586. 

  586.          DO i = its, MIN(ite,ide-1)
    587. 

  587.            grid%fis(I,J)=grid%ht_gc(I,J)*g
    588. 

  588. !
    589. 

  589. !       IF ( grid%p_gc(I,J,1) .ne. 200100. .AND.  (grid%ht_gc(I,J) .eq. grid%ght_gc(I,J,1)) .AND. grid%ht_gc(I,J) .ne. 0) THEN
    590. 

  590.         IF ( grid%p_gc(I,J,1) .ne. 200100. .AND.  (abs(grid%ht_gc(I,J)-grid%ght_gc(I,J,1)) .lt. 0.01) .AND. grid%ht_gc(I,J) .ne. 0) THEN
    591. 

  591.           IF (mod(I,10) .eq. 0 .and. mod(J,10) .eq. 0) THEN
    592. 

  592.             write(message,*) 'grid%ht_gc and grid%toposoil to swap, flag_soilhgt ::: ', &
    593. 

  593.                           I,J, grid%ht_gc(I,J),grid%toposoil(I,J),flag_soilhgt
    594. 

  594.             CALL wrf_debug(10,message)
    595. 

  595.           ENDIF
    596. 

  596.                 IF ( ( flag_soilhgt.EQ. 1 ) ) THEN
    597. 

  597.                  grid%ght_gc(I,J,1)=grid%toposoil(I,J)
    598. 

  598.                 ENDIF
    599. 

  599.         ENDIF
    600. 

  600. 

  601.          ENDDO
    602. 

  602.        ENDDO
    603. 

  603. 

  604.        numzero=0
    605. 

  605.        numexamined=0
    606. 

  606.        DO j = jts, MIN(jte,jde-1)
    607. 

  607.           DO i = its, MIN(ite,ide-1)
    608. 

  608.              numexamined=numexamined+1
    609. 

  609.              if(grid%fis(i,j)<1e-5 .and. grid%fis(i,j)>-1e5 ) then
    610. 

  610.                 numzero=numzero+1
    611. 

  611.              end if
    612. 

  612.           enddo
    613. 

  613.        enddo
    614. 

  614.        write(message,*) 'TOTAL NEAR-ZERO FIS POINTS: ',numzero,' OF ',numexamined
    615. 

  615.        call wrf_debug(10,message)
    616. 

  616. #if defined(HWRF)
    617. 

  617.        interp_notph: if(.not. grid%use_prep_hybrid) then
    618. 

  618. #endif
    619. 

  619.       if (.NOT. allocated(PDVP))     allocate(PDVP(IMS:IME,JMS:JME))
    620. 

  620.       if (.NOT. allocated(P3D_OUT))  allocate(P3D_OUT(IMS:IME,JMS:JME,KDS:KDE-1))
    621. 

  621.       if (.NOT. allocated(PSFC_OUTV)) allocate(PSFC_OUTV(IMS:IME,JMS:JME))
    622. 

  622.       if (.NOT. allocated(P3DV_OUT)) allocate(P3DV_OUT(IMS:IME,JMS:JME,KDS:KDE-1))
    623. 

  623.       if (.NOT. allocated(P3DV_IN))  allocate(P3DV_IN(IMS:IME,JMS:JME,num_metgrid_levels))
    624. 

  624. 

  625.       CALL compute_nmm_surfacep (grid%ht_gc, grid%ght_gc, grid%p_gc , grid%t_gc               &
    626. 

  626.      &,                          grid%psfc_out, num_metgrid_levels  &
    627. 

  627.      &,                          IDS,IDE,JDS,JDE,KDS,KDE             &
    628. 

  628.      &,                          IMS,IME,JMS,JME,KMS,KME             &
    629. 

  629.      &,                          ITS,ITE,JTS,JTE,KTS,KTE ) ! H points
    630. 

  630. 

  631.        if (internal_time_loop .eq. 1) then
    632. 

  632. 

  633.        write(message,*) 'psfc points (final combined)'
    634. 

  634. 	loopinc=max( (JTE-JTS)/20,1)
    635. 

  635. 	iloopinc=max( (ITE-ITS)/10,1)
    636. 

  636.        CALL wrf_message(message)
    637. 

  637.        DO J=min(JTE,JDE-1),JTS,-loopinc
    638. 

  638.          write(message,633) (grid%psfc_out(I,J)/100.,I=its,min(ite,IDE-1),iloopinc)
    639. 

  639.          CALL wrf_message(message)
    640. 

  640.        ENDDO
    641. 

  641.        
    642. 

  642.        endif
    643. 

  643. 

  644.   633   format(35(f5.0,1x))
    645. 

  645. 

  646.       CALL compute_3d_pressure (grid%psfc_out,grid%aeta1,grid%aeta2   &
    647. 

  647.      &,            grid%pdtop,grid%pt,grid%pd,p3d_out                 &
    648. 

  648.      &,            IDS,IDE,JDS,JDE,KDS,KDE             &
    649. 

  649.      &,            IMS,IME,JMS,JME,KMS,KME             &
    650. 

  650.      &,            ITS,ITE,JTS,JTE,KTS,KTE )
    651. 

  651. 

  652. #ifdef DM_PARALLEL
    653. 

  653.         ips=its ; ipe=ite ;  jps=jts ; jpe=jte ; kps=kts ; kpe=kte
    654. 

  654. # include "HALO_NMM_MG2.inc"
    655. 

  655. #endif
    656. 

  656. 

  657. #ifdef DM_PARALLEL
    658. 

  658. # include "HALO_NMM_MG3.inc"
    659. 

  659. #endif
    660. 

  660. 

  661.        do K=1,num_metgrid_levels
    662. 

  662.         do J=JTS,min(JTE,JDE-1)
    663. 

  663.          do I=ITS,min(ITE,IDE-1)
    664. 

  664. 

  665.          IF (K .eq. KTS) THEN
    666. 

  666.            IF (J .eq. JDS .and. I .lt. IDE-1) THEN  ! S boundary
    667. 

  667.              PDVP(I,J)=0.5*(grid%pd(I,J)+grid%pd(I+1,J))
    668. 

  668.              PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J)+grid%psfc_out(I+1,J))
    669. 

  669.            ELSEIF (J .eq. JDE-1 .and. I .lt. IDE-1) THEN ! N boundary
    670. 

  670.              PDVP(I,J)=0.5*(grid%pd(I,J)+grid%pd(I+1,J))
    671. 

  671.              PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J)+grid%psfc_out(I+1,J))
    672. 

  672.            ELSEIF (I .eq. IDS .and. mod(J,2) .eq. 0) THEN ! W boundary
    673. 

  673.              PDVP(I,J)=0.5*(grid%pd(I,J-1)+grid%pd(I,J+1))
    674. 

  674.              PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J-1)+grid%psfc_out(I,J+1))
    675. 

  675.            ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 0) THEN ! E boundary
    676. 

  676.              PDVP(I,J)=0.5*(grid%pd(I,J-1)+grid%pd(I,J+1))
    677. 

  677.              PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J-1)+grid%psfc_out(I,J+1))
    678. 

  678.            ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 1) THEN ! phantom E boundary
    679. 

  679.              PDVP(I,J)=grid%pd(I,J)
    680. 

  680.              PSFC_OUTV(I,J)=grid%psfc_out(I,J)
    681. 

  681.            ELSEIF (mod(J,2) .eq. 0) THEN ! interior even row
    682. 

  682.              PDVP(I,J)=0.25*(grid%pd(I,J)+grid%pd(I-1,J)+grid%pd(I,J+1)+grid%pd(I,J-1))
    683. 

  683.              PSFC_OUTV(I,J)=0.25*(grid%psfc_out(I,J)+grid%psfc_out(I-1,J)+ &
    684. 

  684.                                   grid%psfc_out(I,J+1)+grid%psfc_out(I,J-1))
    685. 

  685.            ELSE ! interior odd row
    686. 

  686.              PDVP(I,J)=0.25*(grid%pd(I,J)+grid%pd(I+1,J)+grid%pd(I,J+1)+grid%pd(I,J-1))
    687. 

  687.              PSFC_OUTV(I,J)=0.25*(grid%psfc_out(I,J)+grid%psfc_out(I+1,J)+ &
    688. 

  688.                                   grid%psfc_out(I,J+1)+grid%psfc_out(I,J-1))
    689. 

  689.            ENDIF
    690. 

  690.           ENDIF
    691. 

  691. 

  692.            IF (J .eq. JDS .and. I .lt. IDE-1) THEN  ! S boundary
    693. 

  693.              P3DV_IN(I,J,K)=0.5*(grid%p_gc(I,J,K)+grid%p_gc(I+1,J,K))
    694. 

  694.            ELSEIF (J .eq. JDE-1 .and. I .lt. IDE-1) THEN ! N boundary
    695. 

  695.              P3DV_IN(I,J,K)=0.5*(grid%p_gc(I,J,K)+grid%p_gc(I+1,J,K))
    696. 

  696.            ELSEIF (I .eq. IDS .and. mod(J,2) .eq. 0) THEN ! W boundary
    697. 

  697.              P3DV_IN(I,J,K)=0.5*(grid%p_gc(I,J-1,K)+grid%p_gc(I,J+1,K))
    698. 

  698.            ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 0) THEN ! E boundary
    699. 

  699.              P3DV_IN(I,J,K)=0.5*(grid%p_gc(I,J-1,K)+grid%p_gc(I,J+1,K))
    700. 

  700.            ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 1) THEN ! phantom E boundary
    701. 

  701.              P3DV_IN(I,J,K)=grid%p_gc(I,J,K)
    702. 

  702.            ELSEIF (mod(J,2) .eq. 0) THEN ! interior even row
    703. 

  703.              P3DV_IN(I,J,K)=0.25*(grid%p_gc(I,J,K)+grid%p_gc(I-1,J,K) + &
    704. 

  704.                                   grid%p_gc(I,J+1,K)+grid%p_gc(I,J-1,K))
    705. 

  705.            ELSE ! interior odd row
    706. 

  706.              P3DV_IN(I,J,K)=0.25*(grid%p_gc(I,J,K)+grid%p_gc(I+1,J,K) + &
    707. 

  707.                                   grid%p_gc(I,J+1,K)+grid%p_gc(I,J-1,K))
    708. 

  708.            ENDIF
    709. 

  709. 

  710.          enddo
    711. 

  711.         enddo
    712. 

  712.        enddo
    713. 

  713. 

  714.       CALL compute_3d_pressure (psfc_outv,grid%aeta1,grid%aeta2   &
    715. 

  715.      &,            grid%pdtop,grid%pt,pdvp,p3dv_out              &
    716. 

  716.      &,            IDS,IDE,JDS,JDE,KDS,KDE             &
    717. 

  717.      &,            IMS,IME,JMS,JME,KMS,KME             &
    718. 

  718.      &,            ITS,ITE,JTS,JTE,KTS,KTE )
    719. 

  719. 

  720.       CALL interp_press2press_lin(grid%p_gc, p3d_out        &
    721. 

  721.      &,            grid%t_gc, grid%t,num_metgrid_levels          &
    722. 

  722.      &,            .TRUE.,.TRUE.,.TRUE.               & ! extrap, ignore_lowest, t_field
    723. 

  723.      &,            IDS,IDE,JDS,JDE,KDS,KDE             &
    724. 

  724.      &,            IMS,IME,JMS,JME,KMS,KME             &
    725. 

  725.      &,            ITS,ITE,JTS,JTE,KTS,KTE, internal_time_loop )
    726. 

  726. 

  727. 

  728.       CALL interp_press2press_lin(p3dv_in, p3dv_out        &
    729. 

  729.      &,            grid%u_gc, grid%u,num_metgrid_levels          &
    730. 

  730.      &,            .FALSE.,.TRUE.,.FALSE.              &
    731. 

  731.      &,            IDS,IDE,JDS,JDE,KDS,KDE             &
    732. 

  732.      &,            IMS,IME,JMS,JME,KMS,KME             &
    733. 

  733.      &,            ITS,ITE,JTS,JTE,KTS,KTE, internal_time_loop )
    734. 

  734. 

  735.       CALL interp_press2press_lin(p3dv_in, p3dv_out        &
    736. 

  736.      &,            grid%v_gc, grid%v,num_metgrid_levels          &
    737. 

  737.      &,            .FALSE.,.TRUE.,.FALSE.              &
    738. 

  738.      &,            IDS,IDE,JDS,JDE,KDS,KDE             &
    739. 

  739.      &,            IMS,IME,JMS,JME,KMS,KME             &
    740. 

  740.      &,            ITS,ITE,JTS,JTE,KTS,KTE, internal_time_loop )
    741. 

  741. 

  742.        IF (hyb_coor) THEN
    743. 

  743.        CALL wind_adjust(p3dv_in,p3dv_out,grid%u_gc,grid%v_gc,grid%u,grid%v  &
    744. 

  744.      &,                 num_metgrid_levels,5000.        &
    745. 

  745.      &,                 IDS,IDE,JDS,JDE,KDS,KDE           &
    746. 

  746.      &,                 IMS,IME,JMS,JME,KMS,KME           &
    747. 

  747.      &,                 ITS,ITE,JTS,JTE,KTS,KTE )
    748. 

  748.        ENDIF
    749. 

  749. 

  750. 

  751.          ALLOCATE(qtmp(IMS:IME,JMS:JME,num_metgrid_levels))
    752. 

  752.          ALLOCATE(qtmp2(IMS:IME,JMS:JME,num_metgrid_levels))
    753. 

  753. 

  754.             CALL rh_to_mxrat (grid%rh_gc, grid%t_gc, grid%p_gc, qtmp , .TRUE. , &
    755. 

  755.                         ids , ide , jds , jde , 1 , num_metgrid_levels , &
    756. 

  756.                         ims , ime , jms , jme , 1 , num_metgrid_levels , &
    757. 

  757.                         its , ite , jts , jte , 1 , num_metgrid_levels )
    758. 

  758. 

  759.        do K=1,num_metgrid_levels
    760. 

  760.         do J=JTS,min(JTE,JDE-1)
    761. 

  761.          do I=ITS,min(ITE,IDE-1)
    762. 

  762.            QTMP2(I,J,K)=QTMP(I,J,K)/(1.0+QTMP(I,J,K))
    763. 

  763.          end do
    764. 

  764.         end do
    765. 

  765.        end do
    766. 

  766. 

  767.       CALL interp_press2press_log(grid%p_gc, p3d_out        &
    768. 

  768.      &,            QTMP2, grid%q,num_metgrid_levels          &
    769. 

  769.      &,            .FALSE.,.TRUE.                      &
    770. 

  770.      &,            IDS,IDE,JDS,JDE,KDS,KDE             &
    771. 

  771.      &,            IMS,IME,JMS,JME,KMS,KME             &
    772. 

  772.      &,            ITS,ITE,JTS,JTE,KTS,KTE, internal_time_loop )
    773. 

  773. 

  774.       IF (ALLOCATED(QTMP)) DEALLOCATE(QTMP)
    775. 

  775.       IF (ALLOCATED(QTMP)) DEALLOCATE(QTMP2)
    776. 

  776. #if defined(HWRF)
    777. 

  777.        else ! we are using prep_hybrid
    778. 

  778.           ! Compute surface pressure:
    779. 

  779.           grid%psfc_out=grid%pdtop+grid%pd
    780. 

  780.        end if interp_notph
    781. 

  781. #endif
    782. 

  782. 

  783.          !  Get the monthly values interpolated to the current date
    784. 

  784.          !  for the traditional monthly
    785. 

  785.          !  fields of green-ness fraction and background grid%albedo.
    786. 

  786. 

  787.         if (internal_time_loop .eq. 1 .or. config_flags%sst_update .eq. 1) then
    788. 

  788. 

  789.          CALL monthly_interp_to_date ( grid%greenfrac_gc , current_date , grid%vegfra , &
    790. 

  790.                                        ids , ide , jds , jde , kds , kde , &
    791. 

  791.                                        ims , ime , jms , jme , kms , kme , &
    792. 

  792.                                        its , ite , jts , jte , kts , kte )
    793. 

  793. 

  794.          CALL monthly_interp_to_date ( grid%albedo12m_gc , current_date , grid%albbck , &
    795. 

  795.                                        ids , ide , jds , jde , kds , kde , &
    796. 

  796.                                        ims , ime , jms , jme , kms , kme , &
    797. 

  797.                                        its , ite , jts , jte , kts , kte )
    798. 

  798. 

  799.          !  Get the min/max of each i,j for the monthly green-ness fraction.
    800. 

  800. 

  801.          CALL monthly_min_max ( grid%greenfrac_gc , grid%shdmin , grid%shdmax , &
    802. 

  802.                                 ids , ide , jds , jde , kds , kde , &
    803. 

  803.                                 ims , ime , jms , jme , kms , kme , &
    804. 

  804.                                 its , ite , jts , jte , kts , kte )
    805. 

  805. 

  806.          !  The model expects the green-ness values in percent, not fraction.
    807. 

  807. 

  808.          DO j = jts, MIN(jte,jde-1)
    809. 

  809.            DO i = its, MIN(ite,ide-1)
    810. 

  810. !!              grid%vegfra(i,j) = grid%vegfra(i,j) * 100.
    811. 

  811.               grid%shdmax(i,j) = grid%shdmax(i,j) * 100.
    812. 

  812.               grid%shdmin(i,j) = grid%shdmin(i,j) * 100.
    813. 

  813.               grid%vegfrc(I,J)=grid%vegfra(I,J)
    814. 

  814.            END DO
    815. 

  815.          END DO
    816. 

  816. 

  817.          !  The model expects the albedo fields as
    818. 

  818.          !  a fraction, not a percent.  Set the water values to 8%.
    819. 

  819. 

  820.          DO j = jts, MIN(jte,jde-1)
    821. 

  821.            DO i = its, MIN(ite,ide-1)
    822. 

  822.               if (grid%albbck(i,j) .lt. 5.) then
    823. 

  823.                   write(message,*) 'reset albedo to 8%...  I,J,albbck:: ', I,J,grid%albbck(I,J)
    824. 

  824.                   CALL wrf_debug(10,message)
    825. 

  825.                   grid%albbck(I,J)=8.
    826. 

  826.               endif
    827. 

  827.               grid%albbck(i,j) = grid%albbck(i,j) / 100.
    828. 

  828.               grid%snoalb(i,j) = grid%snoalb(i,j) / 100.
    829. 

  829.               IF ( grid%landmask(i,j) .LT. 0.5 ) THEN
    830. 

  830.                  grid%albbck(i,j) = 0.08
    831. 

  831.                  grid%snoalb(i,j) = 0.08
    832. 

  832.               END IF
    833. 

  833.               grid%albase(i,j)=grid%albbck(i,j)
    834. 

  834.               grid%mxsnal(i,j)=grid%snoalb(i,j)
    835. 

  835.            END DO
    836. 

  836.          END DO
    837. 

  837. 

  838.          endif
    839. 

  839. 

  840. #if defined(HWRF)
    841. 

  841.        if(.not.grid%use_prep_hybrid) then
    842. 

  842. #endif
    843. 

  843. !  new deallocs
    844. 

  844.         DEALLOCATE(p3d_out,p3dv_out,p3dv_in)
    845. 

  845. #if defined(HWRF)
    846. 

  846.        end if
    847. 

  847. #endif
    848. 

  848. 

  849.      END IF     !   <----- END OF VERTICAL INTERPOLATION PART ---->
    850. 

  850. 

  851. 

  852. !! compute SST at each time if updating SST
    853. 

  853.         if (config_flags%sst_update == 1) then
    854. 

  854. 

  855.          DO j = jts, MIN(jde-1,jte)
    856. 

  856.             DO i = its, MIN(ide-1,ite)
    857. 

  857. 

  858.         if (grid%SM(I,J) .lt. 0.5) then
    859. 

  859.             grid%SST(I,J)=0.
    860. 

  860.         endif
    861. 

  861. 

  862.         if (grid%SM(I,J) .gt. 0.5) then
    863. 

  863.             grid%SST(I,J)=grid%NMM_TSK(I,J)
    864. 

  864.             grid%NMM_TSK(I,J)=0.
    865. 

  865.         endif
    866. 

  866. 

  867.         IF ( (grid%NMM_TSK(I,J)+grid%SST(I,J)) .lt. 200. .or. &
    868. 

  868.              (grid%NMM_TSK(I,J)+grid%SST(I,J)) .gt. 350. ) THEN
    869. 

  869.           write(message,*) 'TSK, SST trouble at : ', I,J
    870. 

  870.           CALL wrf_message(message)
    871. 

  871.           write(message,*) 'SM, NMM_TSK,SST ', grid%SM(I,J),grid%NMM_TSK(I,J),grid%SST(I,J)
    872. 

  872.           CALL wrf_message(message)
    873. 

  873.         ENDIF
    874. 

  874. 

  875.             ENDDO
    876. 

  876.          ENDDO
    877. 

  877. 

  878.         endif ! sst_update test
    879. 

  879. 

  880.         if (internal_time_loop .eq. 1) then
    881. 

  881. 

  882. !!! weasd has "snow water equivalent" in mm
    883. 

  883. 

  884.        DO j = jts, MIN(jte,jde-1)
    885. 

  885.          DO i = its, MIN(ite,ide-1)
    886. 

  886. 

  887.       IF(grid%sm(I,J).GT.0.9) THEN
    888. 

  888. 

  889.        IF (grid%xice(I,J) .gt. 0) then
    890. 

  890.          grid%si(I,J)=1.0
    891. 

  891.        ENDIF
    892. 

  892. 

  893. !  SEA
    894. 

  894.               grid%epsr(I,J)=.97
    895. 

  895.               grid%embck(I,J)=.97
    896. 

  896.               grid%gffc(I,J)=0.
    897. 

  897.               grid%albedo(I,J)=.06
    898. 

  898.               grid%albase(I,J)=.06
    899. 

  899.               IF(grid%si (I,J).GT.0.    ) THEN
    900. 

  900. !  SEA-ICE
    901. 

  901.                  grid%sm(I,J)=0.
    902. 

  902.                  grid%si(I,J)=0.
    903. 

  903.                  grid%sice(I,J)=1.
    904. 

  904.                  grid%gffc(I,J)=0. ! just leave zero as irrelevant
    905. 

  905.                  grid%albedo(I,J)=.60
    906. 

  906.                  grid%albase(I,J)=.60
    907. 

  907.               ENDIF
    908. 

  908.            ELSE
    909. 

  909. 

  910.         grid%si(I,J)=5.0*grid%weasd(I,J)/1000.
    911. 

  911. ! LAND
    912. 

  912.         grid%epsr(I,J)=1.0
    913. 

  913.         grid%embck(I,J)=1.0
    914. 

  914.         grid%gffc(I,J)=0.0 ! just leave zero as irrelevant
    915. 

  915.         grid%sice(I,J)=0.
    916. 

  916.         grid%sno(I,J)=grid%si(I,J)*.20
    917. 

  917.            ENDIF
    918. 

  918.         ENDDO
    919. 

  919.         ENDDO
    920. 

  920. 

  921. ! DETERMINE grid%albedo OVER LAND
    922. 

  922.        DO j = jts, MIN(jte,jde-1)
    923. 

  923.          DO i = its, MIN(ite,ide-1)
    924. 

  924.           IF(grid%sm(I,J).LT.0.9.AND.grid%sice(I,J).LT.0.9) THEN
    925. 

  925. ! SNOWFREE albedo
    926. 

  926.             IF ( (grid%sno(I,J) .EQ. 0.0) .OR. &
    927. 

  927.                 (grid%albase(I,J) .GE. grid%mxsnal(I,J) ) ) THEN
    928. 

  928.               grid%albedo(I,J) = grid%albase(I,J)
    929. 

  929.             ELSE
    930. 

  930. ! MODIFY albedo IF SNOWCOVER:
    931. 

  931. ! BELOW SNOWDEPTH THRESHOLD...
    932. 

  932.               IF (grid%sno(I,J) .LT. SNUP) THEN
    933. 

  933.                 RSNOW = grid%sno(I,J)/SNUP
    934. 

  934.                 SNOFAC = 1. - ( EXP(-SALP*RSNOW) - RSNOW*EXP(-SALP))
    935. 

  935. ! ABOVE SNOWDEPTH THRESHOLD...
    936. 

  936.               ELSE
    937. 

  937.                 SNOFAC = 1.0
    938. 

  938.               ENDIF
    939. 

  939. ! CALCULATE grid%albedo ACCOUNTING FOR SNOWDEPTH AND VGFRCK
    940. 

  940.               grid%albedo(I,J) = grid%albase(I,J) &
    941. 

  941.                + (1.0-grid%vegfra(I,J))*SNOFAC*(grid%mxsnal(I,J)-grid%albase(I,J))
    942. 

  942.             ENDIF
    943. 

  943.           END IF
    944. 

  944.           grid%si(I,J)=5.0*grid%weasd(I,J)
    945. 

  945.           grid%sno(I,J)=grid%weasd(I,J)
    946. 

  946. 

  947. !!  convert vegfra
    948. 

  948.           grid%vegfra(I,J)=grid%vegfra(I,J)*100.
    949. 

  949. !
    950. 

  950.         ENDDO
    951. 

  951.       ENDDO
    952. 

  952. 

  953. #ifdef DM_PARALLEL
    954. 

  954. 

  955.         ALLOCATE(SM_G(IDS:IDE,JDS:JDE),SICE_G(IDS:IDE,JDS:JDE))
    956. 

  956. 

  957.         CALL WRF_PATCH_TO_GLOBAL_REAL( grid%sice(IMS,JMS)           &
    958. 

  958.      &,                                SICE_G,grid%DOMDESC         &
    959. 

  959.      &,                               'z','xy'                       &
    960. 

  960.      &,                                IDS,IDE-1,JDS,JDE-1,1,1          &
    961. 

  961.      &,                                IMS,IME,JMS,JME,1,1              &
    962. 

  962.      &,                                ITS,ITE,JTS,JTE,1,1 )
    963. 

  963. 

  964.         CALL WRF_PATCH_TO_GLOBAL_REAL( grid%sm(IMS,JMS)           &
    965. 

  965.      &,                                SM_G,grid%DOMDESC         &
    966. 

  966.      &,                               'z','xy'                       &
    967. 

  967.      &,                                IDS,IDE-1,JDS,JDE-1,1,1          &
    968. 

  968.      &,                                IMS,IME,JMS,JME,1,1              &
    969. 

  969.      &,                                ITS,ITE,JTS,JTE,1,1 )
    970. 

  970. 

  971. 

  972.         IF (WRF_DM_ON_MONITOR()) THEN
    973. 

  973. 

  974.   637   format(40(f3.0,1x))
    975. 

  975. 

  976.         allocate(IHE_G(JDS:JDE-1),IHW_G(JDS:JDE-1))
    977. 

  977.        DO j = JDS, JDE-1
    978. 

  978.           IHE_G(J)=MOD(J+1,2)
    979. 

  979.           IHW_G(J)=IHE_G(J)-1
    980. 

  980.        ENDDO
    981. 

  981. 

  982.       DO ITER=1,10
    983. 

  983.        DO j = jds+1, (jde-1)-1
    984. 

  984.          DO i = ids+1, (ide-1)-1
    985. 

  985. 

  986. ! any sea ice around point in question?
    987. 

  987. 

  988.         IF (SM_G(I,J) .ge. 0.9) THEN
    989. 

  989.           SEAICESUM=SICE_G(I+IHE_G(J),J+1)+SICE_G(I+IHW_G(J),J+1)+ &
    990. 

  990.                     SICE_G(I+IHE_G(J),J-1)+SICE_G(I+IHW_G(J),J-1)
    991. 

  991.           IF (SEAICESUM .ge. 1. .and. SEAICESUM .lt. 3.) THEN
    992. 

  992. 

  993.             IF ((SICE_G(I+IHE_G(J),J+1).lt.0.1 .and. SM_G(I+IHE_G(J),J+1).lt.0.1) .OR. &
    994. 

  994.                 (SICE_G(I+IHW_G(J),J+1).lt.0.1 .and. SM_G(I+IHW_G(J),J+1).lt.0.1) .OR. &
    995. 

  995.                 (SICE_G(I+IHE_G(J),J-1).lt.0.1 .and. SM_G(I+IHE_G(J),J-1).lt.0.1) .OR. &
    996. 

  996.                 (SICE_G(I+IHW_G(J),J-1).lt.0.1 .and. SM_G(I+IHW_G(J),J-1).lt.0.1)) THEN
    997. 

  997. 

  998. !             HAVE SEA ICE AND A SURROUNDING LAND POINT - CONVERT TO SEA ICE
    999. 

  999. 

  1000.               write(message,*) 'making seaice (1): ', I,J
    1001. 

  1001.               CALL wrf_debug(100,message)
    1002. 

  1002.               SICE_G(I,J)=1.0
    1003. 

  1003.               SM_G(I,J)=0.
    1004. 

  1004. 

  1005.             ENDIF
    1006. 

  1006. 

  1007.           ELSEIF (SEAICESUM .ge. 3) THEN
    1008. 

  1008. 

  1009. !       WATER POINT SURROUNDED BY ICE  - CONVERT TO SEA ICE
    1010. 

  1010. 

  1011.             write(message,*) 'making seaice (2): ', I,J
    1012. 

  1012.             CALL wrf_debug(100,message)
    1013. 

  1013.             SICE_G(I,J)=1.0
    1014. 

  1014.             SM_G(I,J)=0.
    1015. 

  1015.           ENDIF
    1016. 

  1016. 

  1017.         ENDIF
    1018. 

  1018. 

  1019.         ENDDO
    1020. 

  1020.        ENDDO
    1021. 

  1021.       ENDDO
    1022. 

  1022. 

  1023.         ENDIF
    1024. 

  1024. 

  1025.         CALL WRF_GLOBAL_TO_PATCH_REAL( SICE_G, grid%sice           &
    1026. 

  1026.      &,                                grid%DOMDESC         &
    1027. 

  1027.      &,                               'z','xy'                       &
    1028. 

  1028.      &,                                IDS,IDE-1,JDS,JDE-1,1,1          &
    1029. 

  1029.      &,                                IMS,IME,JMS,JME,1,1              &
    1030. 

  1030.      &,                                ITS,ITE,JTS,JTE,1,1 )
    1031. 

  1031. 

  1032.         CALL WRF_GLOBAL_TO_PATCH_REAL( SM_G,grid%sm           &
    1033. 

  1033.      &,                                grid%DOMDESC         &
    1034. 

  1034.      &,                               'z','xy'                       &
    1035. 

  1035.      &,                                IDS,IDE-1,JDS,JDE-1,1,1          &
    1036. 

  1036.      &,                                IMS,IME,JMS,JME,1,1              &
    1037. 

  1037.      &,                                ITS,ITE,JTS,JTE,1,1 )
    1038. 

  1038. 

  1039.         IF (WRF_DM_ON_MONITOR()) THEN
    1040. 

  1040. #if defined(HWRF)
    1041. 

  1041.           ! SM_G is still needed for the high-res grid
    1042. 

  1042. #else
    1043. 

  1043.           DEALLOCATE(SM_G)
    1044. 

  1044. #endif
    1045. 

  1045.           deallocate(SICE_G)
    1046. 

  1046.         DEALLOCATE(IHE_G,IHW_G)
    1047. 

  1047. 

  1048.         ENDIF
    1049. 

  1049. 

  1050. !        write(message,*) 'revised sea ice on patch'
    1051. 

  1051. !        CALL wrf_debug(100,message)
    1052. 

  1052. !        DO J=JTE,JTS,-(((JTE-JTS)/25)+1)
    1053. 

  1053. !          write(message,637) (grid%sice(I,J),I=ITS,ITE,ITE/20)
    1054. 

  1054. !          CALL wrf_debug(100,message)
    1055. 

  1055. !        END DO
    1056. 

  1056. 

  1057. #else
    1058. 

  1058. ! serial sea ice reprocessing
    1059. 

  1059.         allocate(IHE(JDS:JDE-1),IHW(JDS:JDE-1))
    1060. 

  1060. 

  1061.        DO j = jts, MIN(jte,jde-1)
    1062. 

  1062.           IHE(J)=MOD(J+1,2)
    1063. 

  1063.           IHW(J)=IHE(J)-1
    1064. 

  1064.        ENDDO
    1065. 

  1065. 

  1066.       DO ITER=1,10
    1067. 

  1067.        DO j = jts+1, MIN(jte,jde-1)-1
    1068. 

  1068.          DO i = its+1, MIN(ite,ide-1)-1
    1069. 

  1069. 

  1070. ! any sea ice around point in question?
    1071. 

  1071. 

  1072.         IF (grid%sm(I,J) .gt. 0.9) THEN
    1073. 

  1073.           SEAICESUM=grid%sice(I+IHE(J),J+1)+grid%sice(I+IHW(J),J+1)+ &
    1074. 

  1074.                   grid%sice(I+IHE(J),J-1)+grid%sice(I+IHW(J),J-1)
    1075. 

  1075.           IF (SEAICESUM .ge. 1. .and. SEAICESUM .lt. 3.) THEN
    1076. 

  1076.             IF ((grid%sice(I+IHE(J),J+1).lt.0.1 .and. grid%sm(I+IHE(J),J+1).lt.0.1) .OR. &
    1077. 

  1077.                 (grid%sice(I+IHW(J),J+1).lt.0.1 .and. grid%sm(I+IHW(J),J+1).lt.0.1) .OR. &
    1078. 

  1078.                 (grid%sice(I+IHE(J),J-1).lt.0.1 .and. grid%sm(I+IHE(J),J-1).lt.0.1) .OR. &
    1079. 

  1079.                 (grid%sice(I+IHW(J),J-1).lt.0.1 .and. grid%sm(I+IHW(J),J-1).lt.0.1)) THEN
    1080. 

  1080. 

  1081. !       HAVE SEA ICE AND A SURROUNDING LAND POINT - CONVERT TO SEA ICE
    1082. 

  1082.               grid%sice(I,J)=1.0
    1083. 

  1083.               grid%sm(I,J)=0.
    1084. 

  1084.             ENDIF
    1085. 

  1085.           ELSEIF (SEAICESUM .ge. 3) THEN
    1086. 

  1086. !       WATER POINT SURROUNDED BY ICE  - CONVERT TO SEA ICE
    1087. 

  1087.         grid%sice(I,J)=1.0
    1088. 

  1088.         grid%sm(I,J)=0.
    1089. 

  1089.           ENDIF
    1090. 

  1090.         ENDIF
    1091. 

  1091. 

  1092.         ENDDO
    1093. 

  1093.        ENDDO
    1094. 

  1094.       ENDDO
    1095. 

  1095. 

  1096.         DEALLOCATE(IHE,IHW)
    1097. 

  1097. #endif
    1098. 

  1098. 

  1099. ! this block meant to guarantee land/sea agreement between sm and landmask
    1100. 

  1100. 

  1101.        DO j = jts, MIN(jte,jde-1)
    1102. 

  1102.          DO i = its, MIN(ite,ide-1)
    1103. 

  1103. 

  1104.           IF (grid%sm(I,J) .gt. 0.5) THEN
    1105. 

  1105.                 grid%landmask(I,J)=0.0
    1106. 

  1106.           ELSEIF (grid%sm(I,J) .lt. 0.5 .and. grid%sice(I,J) .gt. 0.9) then
    1107. 

  1107.                 grid%landmask(I,J)=0.0
    1108. 

  1108.           ELSEIF (grid%sm(I,J) .lt. 0.5 .and. grid%sice(I,J) .lt. 0.1) then
    1109. 

  1109.                 grid%landmask(I,J)=1.0
    1110. 

  1110.           ELSE
    1111. 

  1111.                 write(message,*) 'missed point in grid%landmask definition ' , I,J
    1112. 

  1112.                 CALL wrf_message(message)
    1113. 

  1113.                 grid%landmask(I,J)=0.0
    1114. 

  1114.           ENDIF
    1115. 

  1115. !
    1116. 

  1116.         IF (grid%sice(I,J) .gt. 0.5 .and. grid%nmm_tsk(I,J) .lt. 0.1 .and. grid%sst(I,J) .gt. 0.) THEN
    1117. 

  1117.            write(message,*) 'set grid%nmm_tsk to: ', grid%sst(I,J)
    1118. 

  1118.            CALL wrf_message(message)
    1119. 

  1119.            grid%nmm_tsk(I,J)=grid%sst(I,J)
    1120. 

  1120.            grid%sst(I,J)=0.
    1121. 

  1121.         endif
    1122. 

  1122. 

  1123.         ENDDO
    1124. 

  1124.       ENDDO
    1125. 

  1125. 

  1126.       !  For sf_surface_physics = 1, we want to use close to a 10 cm value
    1127. 

  1127.       !  for the bottom level of the soil temps.
    1128. 

  1128. 

  1129.       IF      ( ( model_config_rec%sf_surface_physics(grid%id) .EQ. 1 ) .AND. &
    1130. 

  1130.                 ( flag_st000010 .EQ. 1 ) ) THEN
    1131. 

  1131.          DO j = jts , MIN(jde-1,jte)
    1132. 

  1132.             DO i = its , MIN(ide-1,ite)
    1133. 

  1133.                grid%soiltb(i,j) = grid%st000010(i,j)
    1134. 

  1134.             END DO
    1135. 

  1135.          END DO
    1136. 

  1136.       END IF
    1137. 

  1137. 

  1138.   !  Adjust the various soil temperature values depending on the difference in
    1139. 

  1139.   !  in elevation between the current model's elevation and the incoming data's
    1140. 

  1140.   !  orography.
    1141. 

  1141. 

  1142.       IF ( ( flag_toposoil .EQ. 1 ) ) THEN
    1143. 

  1143. 

  1144.         ALLOCATE(HT(ims:ime,jms:jme))
    1145. 

  1145. 

  1146.         DO J=jms,jme
    1147. 

  1147.           DO I=ims,ime
    1148. 

  1148.               HT(I,J)=grid%fis(I,J)/9.81
    1149. 

  1149.           END DO
    1150. 

  1150.         END DO
    1151. 

  1151. 

  1152. !       if (maxval(grid%toposoil) .gt. 100.) then
    1153. 

  1153. !
    1154. 

  1154. !  Being avoided.   Something to revisit eventually.
    1155. 

  1155. !
    1156. 

  1156. !1219 might be simply a matter of including toposoil
    1157. 

  1157. !
    1158. 

  1158. !    CODE NOT TESTED AT NCEP USING THIS FUNCTIONALITY,
    1159. 

  1159. !    SO TO BE SAFE WILL AVOID FOR RETRO RUNS.
    1160. 

  1160. !
    1161. 

  1161. !        CALL adjust_soil_temp_new ( grid%soiltb , 2 , &
    1162. 

  1162. !                       grid%nmm_tsk , ht , grid%toposoil , grid%landmask, flag_toposoil , &
    1163. 

  1163. !                       grid%st000010 , st010040 , st040100 , st100200 , st010200 , &
    1164. 

  1164. !                       flag_st000010 , flag_st010040 , flag_st040100 , &
    1165. 

  1165. !                       flag_st100200 , flag_st010200 , &
    1166. 

  1166. !                       soilt000 , soilt005 , soilt020 , soilt040 , &
    1167. 

  1167. !                       soilt160 , soilt300 , &
    1168. 

  1168. !                       flag_soilt000 , flag_soilt005 , flag_soilt020 , &
    1169. 

  1169. !                       flag_soilt040 , flag_soilt160 , flag_soilt300 , &
    1170. 

  1170. !                       ids , ide , jds , jde , kds , kde , &
    1171. 

  1171. !                       ims , ime , jms , jme , kms , kme , &
    1172. 

  1172. !                       its , ite , jts , jte , kts , kte )
    1173. 

  1173. !       endif
    1174. 

  1174. 

  1175.       END IF
    1176. 

  1176. 

  1177.       !  Process the LSM data.
    1178. 

  1178. 

  1179.       !  surface_input_source=1 => use data from static file
    1180. 

  1180.       !                            (fractional category as input)
    1181. 

  1181.       !  surface_input_source=2 => use data from grib file
    1182. 

  1182.       !                            (dominant category as input)
    1183. 

  1183. 

  1184.       IF ( config_flags%surface_input_source .EQ. 1 ) THEN
    1185. 

  1185.          grid%vegcat (its,jts) = 0
    1186. 

  1186.          grid%soilcat(its,jts) = 0
    1187. 

  1187.       END IF
    1188. 

  1188. 

  1189.       !  Generate the vegetation and soil category information
    1190. 

  1190.       !  from the fractional input
    1191. 

  1191.       !  data, or use the existing dominant category fields if they exist.
    1192. 

  1192. 

  1193.       IF ((grid%soilcat(its,jts) .LT. 0.5) .AND. (grid%vegcat(its,jts) .LT. 0.5)) THEN
    1194. 

  1194. 

  1195.          num_veg_cat      = SIZE ( grid%landusef_gc , DIM=3 )
    1196. 

  1196.          num_soil_top_cat = SIZE ( grid%soilctop_gc , DIM=3 )
    1197. 

  1197.          num_soil_bot_cat = SIZE ( grid%soilcbot_gc , DIM=3 )
    1198. 

  1198. 

  1199.         do J=JMS,JME
    1200. 

  1200.         do K=1,num_veg_cat
    1201. 

  1201.         do I=IMS,IME
    1202. 

  1202.            grid%landusef(I,K,J)=grid%landusef_gc(I,J,K)
    1203. 

  1203.         enddo
    1204. 

  1204.         enddo
    1205. 

  1205.         enddo
    1206. 

  1206. 

  1207.         do J=JMS,JME
    1208. 

  1208.         do K=1,num_soil_top_cat
    1209. 

  1209.         do I=IMS,IME
    1210. 

  1210.            grid%soilctop(I,K,J)=grid%soilctop_gc(I,J,K)
    1211. 

  1211.         enddo
    1212. 

  1212.         enddo
    1213. 

  1213.         enddo
    1214. 

  1214. 

  1215.         do J=JMS,JME
    1216. 

  1216.         do K=1,num_soil_bot_cat
    1217. 

  1217.         do I=IMS,IME
    1218. 

  1218.            grid%soilcbot(I,K,J)=grid%soilcbot_gc(I,J,K)
    1219. 

  1219.         enddo
    1220. 

  1220.         enddo
    1221. 

  1221.         enddo
    1222. 

  1222. 

  1223. !       grid%sm (1=water, 0=land)
    1224. 

  1224. !       grid%landmask(0=water, 1=land)
    1225. 

  1225. 

  1226. 

  1227.         write(message,*) 'landmask into process_percent_cat_new'
    1228. 

  1228. 

  1229.         CALL wrf_debug(1,message)
    1230. 

  1230.         do J=JTE,JTS,-(((JTE-JTS)/20)+1)
    1231. 

  1231.         write(message,641) (grid%landmask(I,J),I=ITS,min(ITE,IDE-1),((ITE-ITS)/15)+1)
    1232. 

  1232.         CALL wrf_debug(1,message)
    1233. 

  1233.         enddo
    1234. 

  1234.   641   format(25(f3.0,1x))
    1235. 

  1235. 

  1236.          CALL process_percent_cat_new ( grid%landmask , &
    1237. 

  1237.                          grid%landusef , grid%soilctop , grid%soilcbot , &
    1238. 

  1238.                          grid%isltyp , grid%ivgtyp , &
    1239. 

  1239.                          num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
    1240. 

  1240.                          ids , ide , jds , jde , kds , kde , &
    1241. 

  1241.                          ims , ime , jms , jme , kms , kme , &
    1242. 

  1242.                          its , ite , jts , jte , kts , kte , &
    1243. 

  1243.                          model_config_rec%iswater(grid%id) )
    1244. 

  1244. 

  1245.          DO j = jts , MIN(jde-1,jte)
    1246. 

  1246.             DO i = its , MIN(ide-1,ite)
    1247. 

  1247.                grid%vegcat(i,j)  = grid%ivgtyp(i,j)
    1248. 

  1248.                grid%soilcat(i,j) = grid%isltyp(i,j)
    1249. 

  1249.             END DO
    1250. 

  1250.          END DO
    1251. 

  1251. 

  1252.        ELSE
    1253. 

  1253. 

  1254.          !  Do we have dominant soil and veg data from the input already?
    1255. 

  1255. 

  1256.          IF ( grid%soilcat(its,jts) .GT. 0.5 ) THEN
    1257. 

  1257.             DO j = jts, MIN(jde-1,jte)
    1258. 

  1258.                DO i = its, MIN(ide-1,ite)
    1259. 

  1259.                   grid%isltyp(i,j) = NINT( grid%soilcat(i,j) )
    1260. 

  1260.                END DO
    1261. 

  1261.             END DO
    1262. 

  1262.          END IF
    1263. 

  1263.          IF ( grid%vegcat(its,jts) .GT. 0.5 ) THEN
    1264. 

  1264.             DO j = jts, MIN(jde-1,jte)
    1265. 

  1265.                DO i = its, MIN(ide-1,ite)
    1266. 

  1266.                   grid%ivgtyp(i,j) = NINT( grid%vegcat(i,j) )
    1267. 

  1267.                END DO
    1268. 

  1268.             END DO
    1269. 

  1269.          END IF
    1270. 

  1270. 

  1271.        ENDIF
    1272. 

  1272. 

  1273.         DO j = jts, MIN(jde-1,jte)
    1274. 

  1274.             DO i = its, MIN(ide-1,ite)
    1275. 

  1275. 

  1276.         IF (grid%sice(I,J) .lt. 0.1) THEN
    1277. 

  1277.           IF (grid%landmask(I,J) .gt. 0.5 .and. grid%sm(I,J) .gt. 0.5) THEN
    1278. 

  1278.                 write(message,*) 'land mask and grid%sm both > 0.5: ', &
    1279. 

  1279.                                            I,J,grid%landmask(I,J),grid%sm(I,J)
    1280. 

  1280.                 CALL wrf_message(message)
    1281. 

  1281.                 grid%sm(I,J)=0.
    1282. 

  1282.           ELSEIF (grid%landmask(I,J) .lt. 0.5 .and. grid%sm(I,J) .lt. 0.5) THEN
    1283. 

  1283.                 write(message,*) 'land mask and grid%sm both < 0.5: ', &
    1284. 

  1284.                                            I,J, grid%landmask(I,J),grid%sm(I,J)
    1285. 

  1285.                 CALL wrf_message(message)
    1286. 

  1286.                 grid%sm(I,J)=1.
    1287. 

  1287.           ENDIF
    1288. 

  1288.         ELSE
    1289. 

  1289.           IF (grid%landmask(I,J) .gt. 0.5 .and. grid%sm(I,J)+grid%sice(I,J) .gt. 0.9) then
    1290. 

  1290.             write(message,*) 'landmask says LAND, sm/sice say SEAICE: ', I,J
    1291. 

  1291.           ENDIF
    1292. 

  1292.         ENDIF
    1293. 

  1293. 

  1294.            ENDDO
    1295. 

  1295.         ENDDO
    1296. 

  1296. 

  1297.          DO j = jts, MIN(jde-1,jte)
    1298. 

  1298.             DO i = its, MIN(ide-1,ite)
    1299. 

  1299. 

  1300.         if (grid%sice(I,J) .gt. 0.9) then
    1301. 

  1301.         grid%isltyp(I,J)=16
    1302. 

  1302.         grid%ivgtyp(I,J)=24
    1303. 

  1303.         endif
    1304. 

  1304. 

  1305.             ENDDO
    1306. 

  1306.          ENDDO
    1307. 

  1307. 

  1308.          DO j = jts, MIN(jde-1,jte)
    1309. 

  1309.             DO i = its, MIN(ide-1,ite)
    1310. 

  1310. 

  1311.         if (grid%sm(I,J) .lt. 0.5) then
    1312. 

  1312.             grid%sst(I,J)=0.
    1313. 

  1313.         endif
    1314. 

  1314. 

  1315.         if (grid%sm(I,J) .gt. 0.5) then
    1316. 

  1316.           if (grid%sst(I,J) .lt. 0.1) then
    1317. 

  1317.             grid%sst(I,J)=grid%nmm_tsk(I,J)
    1318. 

  1318.           endif
    1319. 

  1319.             grid%nmm_tsk(I,J)=0.
    1320. 

  1320.         endif
    1321. 

  1321. 

  1322.         IF ( (grid%nmm_tsk(I,J)+grid%sst(I,J)) .lt. 200. .or. &
    1323. 

  1323.              (grid%nmm_tsk(I,J)+grid%sst(I,J)) .gt. 350. ) THEN
    1324. 

  1324.           write(message,*) 'TSK, sst trouble at : ', I,J
    1325. 

  1325.           CALL wrf_message(message)
    1326. 

  1326.           write(message,*) 'sm, nmm_tsk,sst ', grid%sm(I,J),grid%nmm_tsk(I,J),grid%sst(I,J)
    1327. 

  1327.           CALL wrf_message(message)
    1328. 

  1328.         ENDIF
    1329. 

  1329. 

  1330.             ENDDO
    1331. 

  1331.          ENDDO
    1332. 

  1332. 

  1333.         write(message,*) 'grid%sm'
    1334. 

  1334.         CALL wrf_message(message)
    1335. 

  1335. 

  1336.         DO J=min(jde-1,jte),jts,-((jte-jts)/15+1)
    1337. 

  1337.           write(message,635) (grid%sm(i,J),I=its,ite,((ite-its)/10)+1)
    1338. 

  1338.           CALL wrf_message(message)
    1339. 

  1339.         END DO
    1340. 

  1340. 

  1341.         write(message,*) 'sst/nmm_tsk'
    1342. 

  1342.         CALL wrf_debug(10,message)
    1343. 

  1343.         DO J=min(jde-1,jte),jts,-((jte-jts)/15+1)
    1344. 

  1344.           write(message,635) (grid%sst(I,J)+grid%nmm_tsk(I,J),I=ITS,min(ide-1,ite),((ite-its)/10)+1)
    1345. 

  1345.           CALL wrf_debug(10,message)
    1346. 

  1346.         END DO
    1347. 

  1347. 

  1348.   635   format(20(f5.1,1x))
    1349. 

  1349. 

  1350.          DO j = jts, MIN(jde-1,jte)
    1351. 

  1351.             DO i = its, MIN(ide-1,ite)
    1352. 

  1352.                IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN
    1353. 

  1353.                   grid%soiltb(i,j) = grid%sst(i,j)
    1354. 

  1354.                ELSE IF (  grid%landmask(i,j) .GT. 0.5 ) THEN
    1355. 

  1355.                   grid%soiltb(i,j) = grid%nmm_tsk(i,j)
    1356. 

  1356.                END IF
    1357. 

  1357.             END DO
    1358. 

  1358.          END DO
    1359. 

  1359. 

  1360. !      END IF
    1361. 

  1361. 

  1362.    !  Land use categories, dominant soil and vegetation types (if available).
    1363. 

  1363. 

  1364. !       allocate(grid%lu_index(ims:ime,jms:jme))
    1365. 

  1365. 

  1366.           DO j = jts, MIN(jde-1,jte)
    1367. 

  1367.             DO i = its, MIN(ide-1,ite)
    1368. 

  1368.                grid%lu_index(i,j) = grid%ivgtyp(i,j)
    1369. 

  1369.             END DO
    1370. 

  1370.           END DO
    1371. 

  1371. 

  1372.         if (flag_sst .eq. 1) log_flag_sst=.true.
    1373. 

  1373.         if (flag_sst .eq. 0) log_flag_sst=.false.
    1374. 

  1374. 

  1375.         write(message,*) 'st_input dimensions: ', size(st_input,dim=1), &
    1376. 

  1376.                                   size(st_input,dim=2),size(st_input,dim=3)
    1377. 

  1377.         CALL wrf_debug(100,message)
    1378. 

  1378. 

  1379. !        write(message,*) 'maxval st_input(1): ', maxval(st_input(:,1,:))
    1380. 

  1380. !          CALL wrf_message(message)
    1381. 

  1381. !        write(message,*) 'maxval st_input(2): ', maxval(st_input(:,2,:))
    1382. 

  1382. !          CALL wrf_message(message)
    1383. 

  1383. !        write(message,*) 'maxval st_input(3): ', maxval(st_input(:,3,:))
    1384. 

  1384. !          CALL wrf_message(message)
    1385. 

  1385. !        write(message,*) 'maxval st_input(4): ', maxval(st_input(:,4,:))
    1386. 

  1386. !          CALL wrf_message(message)
    1387. 

  1387. 

  1388. ! =============================================================
    1389. 

  1389. 

  1390.    IF (.NOT. ALLOCATED(TG_ALT))ALLOCATE(TG_ALT(grid%sm31:grid%em31,jms:jme))
    1391. 

  1391. 

  1392.       TPH0=TPH0D*DTR
    1393. 

  1393.       WBD=-(((ide-1)-1)*grid%dlmd)
    1394. 

  1394.       WB= WBD*DTR
    1395. 

  1395.       SBD=-(((jde-1)/2)*grid%dphd)
    1396. 

  1396.       SB= SBD*DTR
    1397. 

  1397.       DLM=grid%dlmd*DTR
    1398. 

  1398.       DPH=grid%dp…
    1399.

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