PageRenderTime 51ms CodeModel.GetById 20ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/dyn_nmm/module_initialize_tropical_cyclone.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 6633 lines | 4328 code | 1076 blank | 1229 comment | 142 complexity | 9d9f77a97607ac1b632315424e19711f MD5 | raw file
Possible License(s): AGPL-1.0 
    

  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_ideal
    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. 

  77. real      ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,1:grid%num_metgrid_levels)           :: ght_out
    78. 

  78. real      ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,1:grid%num_metgrid_levels)           :: rh_out
    79. 

  79. real      ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,1:grid%num_metgrid_levels)           :: t_out
    80. 

  80. real      ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,1:grid%num_metgrid_levels)           :: u_out
    81. 

  81. real      ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,1:grid%num_metgrid_levels)           :: v_out
    82. 

  82. real      ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,1:grid%num_land_cat)           :: landusef_out
    83. 

  83. real      ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,1:grid%num_soil_cat)           :: soilcbot_out
    84. 

  84. real      ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,1:grid%num_soil_cat)           :: soilctop_out
    85. 

  85. 

  86.       TYPE (grid_config_rec_type)              :: config_flags
    87. 

  87. 

  88.       !  Local domain indices and counters.
    89. 

  89. 

  90.       INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
    91. 

  91.       INTEGER :: num_veg_gc , num_soil_top_gc , num_soil_bot_gc
    92. 

  92. 

  93.       INTEGER                             ::                       &
    94. 

  94.                                      ids, ide, jds, jde, kds, kde, &
    95. 

  95.                                      ims, ime, jms, jme, kms, kme, &
    96. 

  96.                                      its, ite, jts, jte, kts, kte, &
    97. 

  97.                                      ips, ipe, jps, jpe, kps, kpe, &
    98. 

  98.                                      i, j, k, NNXP, NNYP
    99. 

  99. 

  100.       !  Local data
    101. 

  101. 

  102.         CHARACTER(LEN=19):: start_date
    103. 

  103. 

  104. #ifdef DM_PARALLEL
    105. 

  105. 

  106.         LOGICAL,EXTERNAL :: WRF_DM_ON_MONITOR
    107. 

  107.        logical :: test
    108. 

  108. 

  109. !              INTEGER :: DOMDESC
    110. 

  110.               REAL,ALLOCATABLE    :: SICE_G(:,:), SM_G(:,:)
    111. 

  111.               INTEGER, ALLOCATABLE::  IHE_G(:),IHW_G(:)
    112. 

  112.               INTEGER, ALLOCATABLE::  ITEMP(:,:)
    113. 

  113.               INTEGER :: my_e,my_n,my_s,my_w,my_ne,my_nw,my_se,my_sw,myi,myj,npe
    114. 

  114.               INTEGER :: istat,inpes,jnpes
    115. 

  115. #else
    116. 

  116.         integer, allocatable:: ihw(:),ihe(:)
    117. 

  117. #endif
    118. 

  118. 

  119. 

  120.       CHARACTER (LEN=255) :: message
    121. 

  121. 

  122.       INTEGER :: error
    123. 

  123.       REAL    :: p_surf, p_level
    124. 

  124.       REAL    :: cof1, cof2
    125. 

  125.       REAL    :: qvf , qvf1 , qvf2 , pd_surf
    126. 

  126.       REAL    :: p00 , t00 , a
    127. 

  127.       REAL    :: hold_znw, rmin,rmax
    128. 

  128. 

  129.       REAL :: p_top_requested , ptsgm
    130. 

  130.       INTEGER :: num_metgrid_levels, ICOUNT
    131. 

  131.       REAL , DIMENSION(max_eta) :: eta_levels
    132. 

  132. 

  133.       LOGICAL :: stretch_grid, dry_sounding, debug, log_flag_sst, hyb_coor
    134. 

  134. 

  135.         REAL, ALLOCATABLE,DIMENSION(:,:):: ADUM2D,SNOWC,HT,TG_ALT, &
    136. 

  136.                                            PDVP,PSFC_OUTV
    137. 

  137. 

  138.         REAL, ALLOCATABLE,DIMENSION(:,:,:):: P3D_OUT,P3DV_OUT,P3DV_IN, &
    139. 

  139.                                              QTMP,QTMP2
    140. 

  140. 

  141.         INTEGER, ALLOCATABLE, DIMENSION(:):: KHL2,KVL2,KHH2,KVH2, &
    142. 

  142.                                              KHLA,KHHA,KVLA,KVHA
    143. 

  143. 

  144. !        INTEGER, ALLOCATABLE, DIMENSION(:,:):: grid%lu_index
    145. 

  145. 

  146.         REAL, ALLOCATABLE, DIMENSION(:):: DXJ,WPDARJ,CPGFUJ,CURVJ, &
    147. 

  147.                                           FCPJ,FDIVJ,EMJ,EMTJ,FADJ, &
    148. 

  148.                                           HDACJ,DDMPUJ,DDMPVJ
    149. 

  149. 

  150.         REAL, ALLOCATABLE,DIMENSION(:),SAVE:: SG1,SG2,DSG1,DSG2, &
    151. 

  151.                                               SGML1,SGML2
    152. 

  152. 

  153. !-- Carsel and Parrish [1988]
    154. 

  154.          REAL , DIMENSION(100) :: lqmi
    155. 

  155.          integer iicount
    156. 

  156. 

  157.         REAL:: TPH0D,TLM0D
    158. 

  158.         REAL:: TPH0,WB,SB,TDLM,TDPH
    159. 

  159.         REAL:: WBI,SBI,EBI,ANBI,STPH0,CTPH0
    160. 

  160.         REAL:: TSPH,DTAD,DTCF
    161. 

  161.         REAL:: ACDT,CDDAMP,DXP,FP
    162. 

  162.         REAL:: WBD,SBD
    163. 

  163.         REAL:: RSNOW,SNOFAC
    164. 

  164.         REAL, PARAMETER:: SALP=2.60
    165. 

  165.         REAL, PARAMETER:: SNUP=0.040
    166. 

  166.         REAL:: SMCSUM,STCSUM,SEAICESUM,FISX
    167. 

  167.         REAL:: cur_smc, aposs_smc
    168. 

  168. 

  169.         REAL:: COAC, CODAMP
    170. 

  170. 

  171.         INTEGER,PARAMETER:: DOUBLE=SELECTED_REAL_KIND(15,300)
    172. 

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

  173. 

  174.         INTEGER:: KHH,KVH,JAM,JA, IHL, IHH, L
    175. 

  175.         INTEGER:: II,JJ,ISRCH,ISUM,ITER,Ilook,Jlook
    176. 

  176. 

  177.         REAL, PARAMETER:: DTR=0.01745329
    178. 

  178.         REAL, PARAMETER:: W_NMM=0.08
    179. 

  179. #if defined(HWRF)
    180. 

  180.         REAL, PARAMETER:: DDFC=1.0
    181. 

  181. #else
    182. 

  182.         REAL, PARAMETER:: DDFC=8.0
    183. 

  183. #endif
    184. 

  184.         REAL, PARAMETER:: TWOM=.00014584
    185. 

  185.         REAL, PARAMETER:: CP=1004.6
    186. 

  186.         REAL, PARAMETER:: DFC=1.0
    187. 

  187.         REAL, PARAMETER:: ROI=916.6
    188. 

  188.         REAL, PARAMETER:: R=287.04
    189. 

  189.         REAL, PARAMETER:: CI=2060.0
    190. 

  190.         REAL, PARAMETER:: ROS=1500.
    191. 

  191.         REAL, PARAMETER:: CS=1339.2
    192. 

  192.         REAL, PARAMETER:: DS=0.050
    193. 

  193.         REAL, PARAMETER:: AKS=.0000005
    194. 

  194.         REAL, PARAMETER:: DZG=2.85
    195. 

  195.         REAL, PARAMETER:: DI=.1000
    196. 

  196.         REAL, PARAMETER:: AKI=0.000001075
    197. 

  197.         REAL, PARAMETER:: DZI=2.0
    198. 

  198.         REAL, PARAMETER:: THL=210.
    199. 

  199.         REAL, PARAMETER:: PLQ=70000.
    200. 

  200.         REAL, PARAMETER:: ERAD=6371200.
    201. 

  201.         REAL, PARAMETER:: TG0=258.16
    202. 

  202.         REAL, PARAMETER:: TGA=30.0
    203. 

  203.     integer :: numzero,numexamined
    204. 

  204. #ifdef HWRF
    205. 

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

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

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

  208. 

  209.  REAL, DIMENSION(:,:),    ALLOCATABLE :: NHLAT,NHLON,NVLAT,NVLON,HRES_SM
    210. 

  210.  REAL                                 :: NDLMD,NDPHD,NWBD,NSBD
    211. 

  211.  INTEGER                              :: NIDE,NJDE,ILOC,JLOC
    212. 

  212. 

  213.       INTEGER fid, ierr, nprocs
    214. 

  214.       CHARACTER*255 f65name, SysString
    215. 

  215. 

  216. !============================================================================
    217. 

  217. ! end gopal's doing for ocean coupling
    218. 

  218. !============================================================================
    219. 

  219. #endif
    220. 

  220. 

  221.         if (ALLOCATED(ADUM2D)) DEALLOCATE(ADUM2D)
    222. 

  222.         if (ALLOCATED(TG_ALT)) DEALLOCATE(TG_ALT)
    223. 

  223. 

  224. !#define COPY_IN
    225. 

  225. !#include <scalar_derefs.inc>
    226. 

  226. #ifdef DM_PARALLEL
    227. 

  227. #    include <data_calls.inc>
    228. 

  228. #endif
    229. 

  229. 

  230.       SELECT CASE ( model_data_order )
    231. 

  231.          CASE ( DATA_ORDER_ZXY )
    232. 

  232.             kds = grid%sd31 ; kde = grid%ed31 ;
    233. 

  233.             ids = grid%sd32 ; ide = grid%ed32 ;
    234. 

  234.             jds = grid%sd33 ; jde = grid%ed33 ;
    235. 

  235. 

  236.             kms = grid%sm31 ; kme = grid%em31 ;
    237. 

  237.             ims = grid%sm32 ; ime = grid%em32 ;
    238. 

  238.             jms = grid%sm33 ; jme = grid%em33 ;
    239. 

  239. 

  240.             kts = grid%sp31 ; kte = grid%ep31 ; ! tile is entire patch
    241. 

  241.             its = grid%sp32 ; ite = grid%ep32 ; ! tile is entire patch
    242. 

  242.             jts = grid%sp33 ; jte = grid%ep33 ; ! tile is entire patch
    243. 

  243. 

  244.          CASE ( DATA_ORDER_XYZ )
    245. 

  245.             ids = grid%sd31 ; ide = grid%ed31 ;
    246. 

  246.             jds = grid%sd32 ; jde = grid%ed32 ;
    247. 

  247.             kds = grid%sd33 ; kde = grid%ed33 ;
    248. 

  248. 

  249.             ims = grid%sm31 ; ime = grid%em31 ;
    250. 

  250.             jms = grid%sm32 ; jme = grid%em32 ;
    251. 

  251.             kms = grid%sm33 ; kme = grid%em33 ;
    252. 

  252. 

  253.             its = grid%sp31 ; ite = grid%ep31 ; ! tile is entire patch
    254. 

  254.             jts = grid%sp32 ; jte = grid%ep32 ; ! tile is entire patch
    255. 

  255.             kts = grid%sp33 ; kte = grid%ep33 ; ! tile is entire patch
    256. 

  256. 

  257.          CASE ( DATA_ORDER_XZY )
    258. 

  258.             ids = grid%sd31 ; ide = grid%ed31 ;
    259. 

  259.             kds = grid%sd32 ; kde = grid%ed32 ;
    260. 

  260.             jds = grid%sd33 ; jde = grid%ed33 ;
    261. 

  261. 

  262.             ims = grid%sm31 ; ime = grid%em31 ;
    263. 

  263.             kms = grid%sm32 ; kme = grid%em32 ;
    264. 

  264.             jms = grid%sm33 ; jme = grid%em33 ;
    265. 

  265. 

  266.             its = grid%sp31 ; ite = grid%ep31 ; ! tile is entire patch
    267. 

  267.             kts = grid%sp32 ; kte = grid%ep32 ; ! tile is entire patch
    268. 

  268.             jts = grid%sp33 ; jte = grid%ep33 ; ! tile is entire patch
    269. 

  269. 

  270.       END SELECT
    271. 

  271. 

  272. #ifdef DM_PARALLEL
    273. 

  273.       CALL WRF_GET_MYPROC(MYPE)
    274. 

  274.       CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
    275. 

  275.       call wrf_get_nprocx(inpes)
    276. 

  276.       call wrf_get_nprocy(jnpes)
    277. 

  277. !
    278. 

  278.       allocate(itemp(inpes,jnpes),stat=istat)
    279. 

  279.       npe=0
    280. 

  280. !
    281. 

  281.       do j=1,jnpes
    282. 

  282.       do i=1,inpes
    283. 

  283.         itemp(i,j)=npe
    284. 

  284.         if(npe==mype)then
    285. 

  285.           myi=i
    286. 

  286.           myj=j
    287. 

  287.         endif
    288. 

  288.         npe=npe+1
    289. 

  289.       enddo
    290. 

  290.       enddo
    291. 

  291. !
    292. 

  292.       my_n=-1
    293. 

  293.       if(myj+1<=jnpes)my_n=itemp(myi,myj+1)
    294. 

  294. !
    295. 

  295.       my_e=-1
    296. 

  296.       if(myi+1<=inpes)my_e=itemp(myi+1,myj)
    297. 

  297. !
    298. 

  298.       my_s=-1
    299. 

  299.       if(myj-1>=1)my_s=itemp(myi,myj-1)
    300. 

  300. !
    301. 

  301.       my_w=-1
    302. 

  302.       if(myi-1>=1)my_w=itemp(myi-1,myj)
    303. 

  303. !
    304. 

  304.       my_ne=-1
    305. 

  305.       if((myi+1<=inpes).and.(myj+1<=jnpes)) &
    306. 

  306.          my_ne=itemp(myi+1,myj+1)
    307. 

  307. !
    308. 

  308.       my_se=-1
    309. 

  309.       if((myi+1<=inpes).and.(myj-1>=1)) &
    310. 

  310.          my_se=itemp(myi+1,myj-1)
    311. 

  311. !
    312. 

  312.       my_sw=-1
    313. 

  313.       if((myi-1>=1).and.(myj-1>=1)) &
    314. 

  314.          my_sw=itemp(myi-1,myj-1)
    315. 

  315. !
    316. 

  316.       my_nw=-1
    317. 

  317.       if((myi-1>=1).and.(myj+1<=jnpes)) &
    318. 

  318.          my_nw=itemp(myi-1,myj+1)
    319. 

  319. !
    320. 

  320. !     my_neb(1)=my_n
    321. 

  321. !     my_neb(2)=my_e
    322. 

  322. !     my_neb(3)=my_s
    323. 

  323. !     my_neb(4)=my_w
    324. 

  324. !     my_neb(5)=my_ne
    325. 

  325. !     my_neb(6)=my_se
    326. 

  326. !     my_neb(7)=my_sw
    327. 

  327. !     my_neb(8)=my_nw
    328. 

  328. !
    329. 

  329.       deallocate(itemp)
    330. 

  330. #endif
    331. 

  331. 

  332.         grid%DT=float(grid%TIME_STEP)
    333. 

  333. 

  334.         NNXP=min(ITE,IDE-1)
    335. 

  335.         NNYP=min(JTE,JDE-1)
    336. 

  336. 

  337.         write(message,*) 'IDE, JDE: ', IDE,JDE
    338. 

  338.         write(message,*) 'NNXP, NNYP: ', NNXP,NNYP
    339. 

  339.         CALL wrf_message(message)
    340. 

  340. 

  341.         JAM=6+2*(JDE-JDS-10)
    342. 

  342. 

  343.         if (internal_time_loop .eq. 1) then
    344. 

  344.           ALLOCATE(ADUM2D(grid%sm31:grid%em31,jms:jme))
    345. 

  345.           ALLOCATE(KHL2(JTS:NNYP),KVL2(JTS:NNYP),KHH2(JTS:NNYP),KVH2(JTS:NNYP))
    346. 

  346.           ALLOCATE(DXJ(JTS:NNYP),WPDARJ(JTS:NNYP),CPGFUJ(JTS:NNYP),CURVJ(JTS:NNYP))
    347. 

  347.           ALLOCATE(FCPJ(JTS:NNYP),FDIVJ(JTS:NNYP),&
    348. 

  348.                    FADJ(JTS:NNYP))
    349. 

  349.           ALLOCATE(HDACJ(JTS:NNYP),DDMPUJ(JTS:NNYP),DDMPVJ(JTS:NNYP))
    350. 

  350.           ALLOCATE(KHLA(JAM),KHHA(JAM))
    351. 

  351.           ALLOCATE(KVLA(JAM),KVHA(JAM))
    352. 

  352.         endif
    353. 

  353. 

  354. 

  355.     CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
    356. 

  356. 

  357.        IF ( CONFIG_FLAGS%FRACTIONAL_SEAICE == 1 ) THEN
    358. 

  358.           CALL WRF_ERROR_FATAL("NMM cannot use FRACTIONAL_SEAICE = 1")
    359. 

  359.        ENDIF
    360. 

  360. 

  361.       if ( config_flags%bl_pbl_physics == BOULACSCHEME ) then
    362. 

  362.          call wrf_error_fatal("Cannot use BOULAC PBL with NMM")
    363. 

  363.       endif
    364. 

  364. 

  365.         write(message,*) 'cen_lat: ', config_flags%cen_lat
    366. 

  366.         CALL wrf_debug(100,message)
    367. 

  367.         write(message,*) 'cen_lon: ', config_flags%cen_lon
    368. 

  368.         CALL wrf_debug(100,message)
    369. 

  369.         write(message,*) 'dx: ', config_flags%dx
    370. 

  370.         CALL wrf_debug(100,message)
    371. 

  371.         write(message,*) 'dy: ', config_flags%dy
    372. 

  372.         CALL wrf_debug(100,message)
    373. 

  373.         write(message,*) 'config_flags%start_year: ', config_flags%start_year
    374. 

  374.         CALL wrf_debug(100,message)
    375. 

  375.         write(message,*) 'config_flags%start_month: ', config_flags%start_month
    376. 

  376.         CALL wrf_debug(100,message)
    377. 

  377.         write(message,*) 'config_flags%start_day: ', config_flags%start_day
    378. 

  378.         CALL wrf_debug(100,message)
    379. 

  379.         write(message,*) 'config_flags%start_hour: ', config_flags%start_hour
    380. 

  380.         CALL wrf_debug(100,message)
    381. 

  381. 

  382.         write(start_date,435) config_flags%start_year, config_flags%start_month, &
    383. 

  383.                 config_flags%start_day, config_flags%start_hour
    384. 

  384.   435   format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':00:00')
    385. 

  385. 

  386.         grid%dlmd=config_flags%dx
    387. 

  387.         grid%dphd=config_flags%dy
    388. 

  388.         tph0d=config_flags%cen_lat
    389. 

  389.         tlm0d=config_flags%cen_lon
    390. 

  390. 

  391. !==========================================================================
    392. 

  392. 

  393. !!
    394. 

  394. 

  395.  !  Check to see if the boundary conditions are set
    396. 

  396.  !  properly in the namelist file.
    397. 

  397.  !  This checks for sufficiency and redundancy.
    398. 

  398. 

  399.       CALL boundary_condition_check( config_flags, bdyzone, error, grid%id )
    400. 

  400. 

  401.       !  Some sort of "this is the first time" initialization.  Who knows.
    402. 

  402. 

  403.       grid%itimestep=0
    404. 

  404. 

  405.       !  Pull in the info in the namelist to compare it to the input data.
    406. 

  406. 

  407.       grid%real_data_init_type = model_config_rec%real_data_init_type
    408. 

  408.       write(message,*) 'what is flag_metgrid: ', flag_metgrid
    409. 

  409.       CALL wrf_message(message)
    410. 

  410. 

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

  412. 

  413.      num_metgrid_levels = grid%num_metgrid_levels
    414. 

  414. 

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

  416. !
    417. 

  417. ! gopal's doing for ideal cases
    418. 

  418. !
    419. 

  419. 

  420.  num_veg_gc      = SIZE ( grid%landusef_gc , DIM=3 )
    421. 

  421.  num_soil_top_gc = SIZE ( grid%soilctop_gc , DIM=3 )
    422. 

  422.  num_soil_bot_gc = SIZE ( grid%soilcbot_gc , DIM=3 )
    423. 

  423. 

  424. #ifdef DM_PARALLEL
    425. 

  425. ips=its ; ipe=ite ;  jps=jts ; jpe=jte ; kps=kts ; kpe=kte
    426. 

  426. !JWB # include "HALO_NMM_IDEAL_1.inc"
    427. 

  427. #endif
    428. 

  428. !
    429. 

  429.   CALL vortex ( grid%ght_gc,grid%rh_gc,grid%t_gc,grid%u_gc,grid%v_gc,grid%p_gc &
    430. 

  430.      &,         ght_out,rh_out,t_out,u_out,v_out      &
    431. 

  431.      &,         grid%ht_gc,grid%tsk_gc,grid%xice_gc                          &
    432. 

  432.      &,          grid%hlat_gc,grid%hlon_gc,grid%vlat_gc,grid%vlon_gc               &
    433. 

  433.      &,          grid%greenfrac_gc,grid%albedo12m_gc,grid%landusef_gc    &
    434. 

  434.      &,          grid%soilctop_gc,grid%soilcbot_gc             &
    435. 

  435.      &,          landusef_out,soilctop_out,soilcbot_out        &
    436. 

  436.      &,          num_veg_gc,num_soil_top_gc,num_soil_bot_gc    &
    437. 

  437.      &,          config_flags%dx,internal_time_loop            &
    438. 

  438.      &,          1,grid%num_metgrid_levels                          &
    439. 

  439.      &,          ids,ide,jds,jde,kds,kde                       &
    440. 

  440.      &,          ims,ime,jms,jme,kms,kme                       &
    441. 

  441.      &,          its,ite,jts,jte,kts,kte                       )
    442. 

  442. 

  443. !----------------------------------------------------------------------
    444. 

  444. 

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

  446. 

  447.            write(message,*) 'normal ground up file order'
    448. 

  448.            hyb_coor=.false.
    449. 

  449.            CALL wrf_message(message)
    450. 

  450. 

  451.         ELSE
    452. 

  452. 

  453.            hyb_coor=.true.
    454. 

  454.            write(message,*) 'reverse the order of coordinate'
    455. 

  455.            CALL wrf_message(message)
    456. 

  456. 

  457.            CALL reverse_vert_coord(grid%ght_gc, 2, num_metgrid_levels &
    458. 

  458.      &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
    459. 

  459.      &,                            IMS,IME,JMS,JME,KMS,KME        &
    460. 

  460.      &,                            ITS,ITE,JTS,JTE,KTS,KTE )
    461. 

  461. 

  462. #if defined(HWRF)
    463. 

  463.           if(.not. grid%use_prep_hybrid) then
    464. 

  464. #endif
    465. 

  465. 

  466.            CALL reverse_vert_coord(grid%p_gc, 2, num_metgrid_levels &
    467. 

  467.      &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
    468. 

  468.      &,                            IMS,IME,JMS,JME,KMS,KME        &
    469. 

  469.      &,                            ITS,ITE,JTS,JTE,KTS,KTE )
    470. 

  470. 

  471.            CALL reverse_vert_coord(grid%t_gc, 2, num_metgrid_levels &
    472. 

  472.      &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
    473. 

  473.      &,                            IMS,IME,JMS,JME,KMS,KME        &
    474. 

  474.      &,                            ITS,ITE,JTS,JTE,KTS,KTE )
    475. 

  475. 

  476.            CALL reverse_vert_coord(grid%u_gc, 2, num_metgrid_levels &
    477. 

  477.      &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
    478. 

  478.      &,                            IMS,IME,JMS,JME,KMS,KME        &
    479. 

  479.      &,                            ITS,ITE,JTS,JTE,KTS,KTE )
    480. 

  480. 

  481.            CALL reverse_vert_coord(grid%v_gc, 2, num_metgrid_levels &
    482. 

  482.      &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
    483. 

  483.      &,                            IMS,IME,JMS,JME,KMS,KME        &
    484. 

  484.      &,                            ITS,ITE,JTS,JTE,KTS,KTE )
    485. 

  485. 

  486.            CALL reverse_vert_coord(grid%rh_gc, 2, num_metgrid_levels &
    487. 

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

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

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

  490. 

  491. #if defined(HWRF)
    492. 

  492.           endif
    493. 

  493. #endif
    494. 

  494. 

  495.         endif
    496. 

  496. 

  497. 

  498.         IF (hyb_coor) THEN
    499. 

  499.                            ! limit extreme deviations from source model topography
    500. 

  500.                            ! due to potential for nasty extrapolation/interpolation issues
    501. 

  501.                            !
    502. 

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

  503.           CALL wrf_debug(100,message)
    504. 

  504.           ICOUNT=0
    505. 

  505.           DO J=JTS,min(JTE,JDE-1)
    506. 

  506.            DO I=ITS,min(ITE,IDE-1)
    507. 

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

  508.                grid%ht_gc(I,J)=grid%ght_gc(I,J,2)-150.
    509. 

  509.                IF (ICOUNT .LT. 20) THEN
    510. 

  510.                  write(message,*) 'increasing NMM topo toward RUC  ', I,J
    511. 

  511.                  CALL wrf_debug(100,message)
    512. 

  512.                  ICOUNT=ICOUNT+1
    513. 

  513.                ENDIF
    514. 

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

  515.                grid%ht_gc(I,J)=grid%ght_gc(I,J,2)+150.
    516. 

  516.                IF (ICOUNT .LT. 20) THEN
    517. 

  517.                  write(message,*) 'decreasing NMM topo toward RUC ', I,J
    518. 

  518.                  CALL wrf_debug(100,message)
    519. 

  519.                  ICOUNT=ICOUNT+1
    520. 

  520.                ENDIF
    521. 

  521.              ENDIF
    522. 

  522.            END DO
    523. 

  523.           END DO
    524. 

  524. 

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

  526.           CALL wrf_debug(100,message)
    527. 

  527.         ENDIF
    528. 

  528. 

  529.       CALL boundary_smooth(grid%ht_gc,grid%landmask, grid, 12 , 12 &
    530. 

  530.      &,                          IDS,IDE,JDS,JDE,KDS,KDE             &
    531. 

  531.      &,                          IMS,IME,JMS,JME,KMS,KME             &
    532. 

  532.      &,                          ITS,ITE,JTS,JTE,KTS,KTE )
    533. 

  533. 

  534.        DO j = jts, MIN(jte,jde-1)
    535. 

  535.          DO i = its, MIN(ite,ide-1)
    536. 

  536.            if (grid%landmask(I,J) .gt. 0.5) grid%sm(I,J)=0.
    537. 

  537.            if (grid%landmask(I,J) .le. 0.5) grid%sm(I,J)=1.
    538. 

  538.         if (grid%tsk_gc(I,J) .gt. 0.) then
    539. 

  539.            grid%nmm_tsk(I,J)=grid%tsk_gc(I,J)
    540. 

  540.         else
    541. 

  541. #if defined(HWRF)
    542. 

  542.                 if(grid%use_prep_hybrid) then
    543. 

  543.                    if(grid%t(I,J,1)<100) then
    544. 

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

  545.                            I,J,grid%TSK_GC(I,J),grid%T(I,J,1)
    546. 

  546.                    else
    547. 

  547.                       grid%nmm_tsk(I,J)=grid%t(I,J,1) ! stopgap measure
    548. 

  548.                    end if
    549. 

  549.                 else
    550. 

  550. #endif
    551. 

  551.            grid%nmm_tsk(I,J)=grid%t_gc(I,J,1) ! stopgap measure
    552. 

  552. #if defined(HWRF)
    553. 

  553.                 endif
    554. 

  554. #endif
    555. 

  555.         endif
    556. 

  556. !
    557. 

  557.            grid%glat(I,J)=grid%hlat_gc(I,J)*DEGRAD
    558. 

  558.            grid%glon(I,J)=grid%hlon_gc(I,J)*DEGRAD
    559. 

  559.            grid%weasd(I,J)=grid%snow(I,J)
    560. 

  560.            grid%xice(I,J)=grid%xice_gc(I,J)
    561. 

  561.          ENDDO
    562. 

  562.        ENDDO
    563. 

  563. ! First item is to define the target vertical coordinate
    564. 

  564. 

  565.      num_metgrid_levels = grid%num_metgrid_levels
    566. 

  566.      eta_levels(1:kde) = model_config_rec%eta_levels(1:kde)
    567. 

  567.      ptsgm             = model_config_rec%ptsgm
    568. 

  568.      p_top_requested = grid%p_top_requested
    569. 

  569.      grid%pt=p_top_requested
    570. 

  570. 

  571.         if (internal_time_loop .eq. 1) then
    572. 

  572. 

  573.         if (eta_levels(1) .ne. 1.0) then
    574. 

  574. #if defined(HWRF)
    575. 

  575.              if(grid%use_prep_hybrid) then
    576. 

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

  577.              end if
    578. 

  578. #endif
    579. 

  579. 

  580.           write(message,*) '********************************************************************* '
    581. 

  581.           CALL wrf_message(message)
    582. 

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

  583.           CALL wrf_message(message)
    584. 

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

  585.           CALL wrf_message(message)
    586. 

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

  587.           CALL wrf_message(message)
    588. 

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

  589.           CALL wrf_message(message)
    590. 

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

  591.           CALL wrf_message(message)
    592. 

  592.           write(message,*) '**  namelist. '
    593. 

  593.           CALL wrf_message(message)
    594. 

  594.           write(message,*) '********************************************************************** '
    595. 

  595.           CALL wrf_message(message)
    596. 

  596. 

  597.           CALL compute_nmm_levels(KDE,p_top_requested,eta_levels)
    598. 

  598. 

  599.           DO L=1,KDE
    600. 

  600.             write(message,*) 'L, eta_levels(L) returned :: ', L,eta_levels(L)
    601. 

  601.             CALL wrf_message(message)
    602. 

  602.           ENDDO
    603. 

  603. 

  604.         endif
    605. 

  605. 

  606.         write(message,*) 'KDE-1: ', KDE-1
    607. 

  607.         CALL wrf_debug(1,message)
    608. 

  608.         allocate(SG1(1:KDE-1))
    609. 

  609.         allocate(SG2(1:KDE-1))
    610. 

  610.         allocate(DSG1(1:KDE-1))
    611. 

  611.         allocate(DSG2(1:KDE-1))
    612. 

  612.         allocate(SGML1(1:KDE))
    613. 

  613.         allocate(SGML2(1:KDE))
    614. 

  614. 

  615.       CALL define_nmm_vertical_coord (kde-1, ptsgm, grid%pt,grid%pdtop, eta_levels, &
    616. 

  616.                                       grid%eta1,grid%deta1,grid%aeta1,             &
    617. 

  617.                                       grid%eta2,grid%deta2,grid%aeta2, grid%dfl, grid%dfrlg         )
    618. 

  618. 

  619.        DO L=KDS,KDE-1
    620. 

  620.         grid%deta(L)=eta_levels(L)-eta_levels(L+1)
    621. 

  621.        ENDDO
    622. 

  622.         endif
    623. 

  623. 

  624.         write(message,*) 'num_metgrid_levels: ', num_metgrid_levels
    625. 

  625.         CALL wrf_message(message)
    626. 

  626. 

  627.        DO j = jts, MIN(jte,jde-1)
    628. 

  628.          DO i = its, MIN(ite,ide-1)
    629. 

  629.            grid%fis(I,J)=grid%ht_gc(I,J)*g
    630. 

  630. !
    631. 

  631. !       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
    632. 

  632.         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
    633. 

  633.           IF (mod(I,10) .eq. 0 .and. mod(J,10) .eq. 0) THEN
    634. 

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

  635.                           I,J, grid%ht_gc(I,J),grid%toposoil(I,J),flag_soilhgt
    636. 

  636.             CALL wrf_debug(10,message)
    637. 

  637.           ENDIF
    638. 

  638.                 IF ( ( flag_soilhgt.EQ. 1 ) ) THEN
    639. 

  639.                  grid%ght_gc(I,J,1)=grid%toposoil(I,J)
    640. 

  640.                 ENDIF
    641. 

  641.         ENDIF
    642. 

  642. 

  643.          ENDDO
    644. 

  644.        ENDDO
    645. 

  645. 

  646.        numzero=0
    647. 

  647.        numexamined=0
    648. 

  648.        DO j = jts, MIN(jte,jde-1)
    649. 

  649.           DO i = its, MIN(ite,ide-1)
    650. 

  650.              numexamined=numexamined+1
    651. 

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

  652.                 numzero=numzero+1
    653. 

  653.              end if
    654. 

  654.           enddo
    655. 

  655.        enddo
    656. 

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

  657.        call wrf_debug(10,message)
    658. 

  658. #if defined(HWRF)
    659. 

  659.        interp_notph: if(.not. grid%use_prep_hybrid) then
    660. 

  660. #endif
    661. 

  661.       if (.NOT. allocated(PDVP))     allocate(PDVP(IMS:IME,JMS:JME))
    662. 

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

  663.       if (.NOT. allocated(PSFC_OUTV)) allocate(PSFC_OUTV(IMS:IME,JMS:JME))
    664. 

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

  665.       if (.NOT. allocated(P3DV_IN))  allocate(P3DV_IN(IMS:IME,JMS:JME,num_metgrid_levels))
    666. 

  666. 

  667.       CALL compute_nmm_surfacep (grid%ht_gc, grid%ght_gc, grid%p_gc , grid%t_gc               &
    668. 

  668.      &,                          grid%psfc_out, num_metgrid_levels  &
    669. 

  669.      &,                          IDS,IDE,JDS,JDE,KDS,KDE             &
    670. 

  670.      &,                          IMS,IME,JMS,JME,KMS,KME             &
    671. 

  671.      &,                          ITS,ITE,JTS,JTE,KTS,KTE ) ! H points
    672. 

  672. 

  673.        if (internal_time_loop .eq. 1) then
    674. 

  674. 

  675.        write(message,*) 'psfc points (final combined)'
    676. 

  676. 	loopinc=max( (JTE-JTS)/20,1)
    677. 

  677. 	iloopinc=max( (ITE-ITS)/10,1)
    678. 

  678.        CALL wrf_message(message)
    679. 

  679.        DO J=min(JTE,JDE-1),JTS,-loopinc
    680. 

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

  681.          CALL wrf_message(message)
    682. 

  682.        ENDDO
    683. 

  683.        
    684. 

  684.        endif
    685. 

  685. 

  686.   633   format(35(f5.0,1x))
    687. 

  687. 

  688.       CALL compute_3d_pressure (grid%psfc_out,grid%aeta1,grid%aeta2   &
    689. 

  689.      &,            grid%pdtop,grid%pt,grid%pd,p3d_out                 &
    690. 

  690.      &,            IDS,IDE,JDS,JDE,KDS,KDE             &
    691. 

  691.      &,            IMS,IME,JMS,JME,KMS,KME             &
    692. 

  692.      &,            ITS,ITE,JTS,JTE,KTS,KTE )
    693. 

  693. 

  694. #ifdef DM_PARALLEL
    695. 

  695.         ips=its ; ipe=ite ;  jps=jts ; jpe=jte ; kps=kts ; kpe=kte
    696. 

  696. # include "HALO_NMM_MG2.inc"
    697. 

  697. #endif
    698. 

  698. 

  699. #ifdef DM_PARALLEL
    700. 

  700. # include "HALO_NMM_MG3.inc"
    701. 

  701. #endif
    702. 

  702. 

  703.        do K=1,num_metgrid_levels
    704. 

  704.         do J=JTS,min(JTE,JDE-1)
    705. 

  705.          do I=ITS,min(ITE,IDE-1)
    706. 

  706. 

  707.          IF (K .eq. KTS) THEN
    708. 

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

  709.              PDVP(I,J)=0.5*(grid%pd(I,J)+grid%pd(I+1,J))
    710. 

  710.              PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J)+grid%psfc_out(I+1,J))
    711. 

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

  712.              PDVP(I,J)=0.5*(grid%pd(I,J)+grid%pd(I+1,J))
    713. 

  713.              PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J)+grid%psfc_out(I+1,J))
    714. 

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

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

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

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

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

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

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

  721.              PDVP(I,J)=grid%pd(I,J)
    722. 

  722.              PSFC_OUTV(I,J)=grid%psfc_out(I,J)
    723. 

  723.            ELSEIF (mod(J,2) .eq. 0) THEN ! interior even row
    724. 

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

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

  726.                                   grid%psfc_out(I,J+1)+grid%psfc_out(I,J-1))
    727. 

  727.            ELSE ! interior odd row
    728. 

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

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

  730.                                   grid%psfc_out(I,J+1)+grid%psfc_out(I,J-1))
    731. 

  731.            ENDIF
    732. 

  732.           ENDIF
    733. 

  733. 

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

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

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

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

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

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

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

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

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

  743.              P3DV_IN(I,J,K)=grid%p_gc(I,J,K)
    744. 

  744.            ELSEIF (mod(J,2) .eq. 0) THEN ! interior even row
    745. 

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

  746.                                   grid%p_gc(I,J+1,K)+grid%p_gc(I,J-1,K))
    747. 

  747.            ELSE ! interior odd row
    748. 

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

  749.                                   grid%p_gc(I,J+1,K)+grid%p_gc(I,J-1,K))
    750. 

  750.            ENDIF
    751. 

  751. 

  752.          enddo
    753. 

  753.         enddo
    754. 

  754.        enddo
    755. 

  755. 

  756.       CALL compute_3d_pressure (psfc_outv,grid%aeta1,grid%aeta2   &
    757. 

  757.      &,            grid%pdtop,grid%pt,pdvp,p3dv_out              &
    758. 

  758.      &,            IDS,IDE,JDS,JDE,KDS,KDE             &
    759. 

  759.      &,            IMS,IME,JMS,JME,KMS,KME             &
    760. 

  760.      &,            ITS,ITE,JTS,JTE,KTS,KTE )
    761. 

  761. 

  762.       CALL interp_press2press_lin(grid%p_gc, p3d_out        &
    763. 

  763.      &,            grid%t_gc, grid%t,num_metgrid_levels          &
    764. 

  764.      &,            .TRUE.,.TRUE.,.TRUE.               & ! extrap, ignore_lowest, t_field
    765. 

  765.      &,            IDS,IDE,JDS,JDE,KDS,KDE             &
    766. 

  766.      &,            IMS,IME,JMS,JME,KMS,KME             &
    767. 

  767.      &,            ITS,ITE,JTS,JTE,KTS,KTE, internal_time_loop )
    768. 

  768. 

  769. 

  770.       CALL interp_press2press_lin(p3dv_in, p3dv_out        &
    771. 

  771.      &,            grid%u_gc, grid%u,num_metgrid_levels          &
    772. 

  772.      &,            .FALSE.,.TRUE.,.FALSE.              &
    773. 

  773.      &,            IDS,IDE,JDS,JDE,KDS,KDE             &
    774. 

  774.      &,            IMS,IME,JMS,JME,KMS,KME             &
    775. 

  775.      &,            ITS,ITE,JTS,JTE,KTS,KTE, internal_time_loop )
    776. 

  776. 

  777.       CALL interp_press2press_lin(p3dv_in, p3dv_out        &
    778. 

  778.      &,            grid%v_gc, grid%v,num_metgrid_levels          &
    779. 

  779.      &,            .FALSE.,.TRUE.,.FALSE.              &
    780. 

  780.      &,            IDS,IDE,JDS,JDE,KDS,KDE             &
    781. 

  781.      &,            IMS,IME,JMS,JME,KMS,KME             &
    782. 

  782.      &,            ITS,ITE,JTS,JTE,KTS,KTE, internal_time_loop )
    783. 

  783. 

  784.        IF (hyb_coor) THEN
    785. 

  785.        CALL wind_adjust(p3dv_in,p3dv_out,grid%u_gc,grid%v_gc,grid%u,grid%v  &
    786. 

  786.      &,                 num_metgrid_levels,5000.        &
    787. 

  787.      &,                 IDS,IDE,JDS,JDE,KDS,KDE           &
    788. 

  788.      &,                 IMS,IME,JMS,JME,KMS,KME           &
    789. 

  789.      &,                 ITS,ITE,JTS,JTE,KTS,KTE )
    790. 

  790.        ENDIF
    791. 

  791. 

  792. 

  793.          ALLOCATE(qtmp(IMS:IME,JMS:JME,num_metgrid_levels))
    794. 

  794.          ALLOCATE(qtmp2(IMS:IME,JMS:JME,num_metgrid_levels))
    795. 

  795. 

  796.             CALL rh_to_mxrat (grid%rh_gc, grid%t_gc, grid%p_gc, qtmp , .TRUE. , &
    797. 

  797.                         ids , ide , jds , jde , 1 , num_metgrid_levels , &
    798. 

  798.                         ims , ime , jms , jme , 1 , num_metgrid_levels , &
    799. 

  799.                         its , ite , jts , jte , 1 , num_metgrid_levels )
    800. 

  800. 

  801.        do K=1,num_metgrid_levels
    802. 

  802.         do J=JTS,min(JTE,JDE-1)
    803. 

  803.          do I=ITS,min(ITE,IDE-1)
    804. 

  804.            QTMP2(I,J,K)=QTMP(I,J,K)/(1.0+QTMP(I,J,K))
    805. 

  805.          end do
    806. 

  806.         end do
    807. 

  807.        end do
    808. 

  808. 

  809.       CALL interp_press2press_log(grid%p_gc, p3d_out        &
    810. 

  810.      &,            QTMP2, grid%q,num_metgrid_levels          &
    811. 

  811.      &,            .FALSE.,.TRUE.                      &
    812. 

  812.      &,            IDS,IDE,JDS,JDE,KDS,KDE             &
    813. 

  813.      &,            IMS,IME,JMS,JME,KMS,KME             &
    814. 

  814.      &,            ITS,ITE,JTS,JTE,KTS,KTE, internal_time_loop )
    815. 

  815. 

  816.       IF (ALLOCATED(QTMP)) DEALLOCATE(QTMP)
    817. 

  817.       IF (ALLOCATED(QTMP)) DEALLOCATE(QTMP2)
    818. 

  818. #if defined(HWRF)
    819. 

  819.        else ! we are using prep_hybrid
    820. 

  820.           ! Compute surface pressure:
    821. 

  821.           grid%psfc_out=grid%pdtop+grid%pd
    822. 

  822.        end if interp_notph
    823. 

  823. #endif
    824. 

  824. 

  825.          !  Get the monthly values interpolated to the current date
    826. 

  826.          !  for the traditional monthly
    827. 

  827.          !  fields of green-ness fraction and background grid%albedo.
    828. 

  828. 

  829.         if (internal_time_loop .eq. 1 .or. config_flags%sst_update .eq. 1) then
    830. 

  830. 

  831.          CALL monthly_interp_to_date ( grid%greenfrac_gc , current_date , grid%vegfra , &
    832. 

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

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

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

  835. 

  836.          CALL monthly_interp_to_date ( grid%albedo12m_gc , current_date , grid%albbck , &
    837. 

  837.                                        ids , ide , jds , jde , kds , kde , &
    838. 

  838.                                        ims , ime , jms , jme , kms , kme , &
    839. 

  839.                                        its , ite , jts , jte , kts , kte )
    840. 

  840. 

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

  842. 

  843.          CALL monthly_min_max ( grid%greenfrac_gc , grid%shdmin , grid%shdmax , &
    844. 

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

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

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

  847. 

  848.          !  The model expects the green-ness values in percent, not fraction.
    849. 

  849. 

  850.          DO j = jts, MIN(jte,jde-1)
    851. 

  851.            DO i = its, MIN(ite,ide-1)
    852. 

  852. !!              grid%vegfra(i,j) = grid%vegfra(i,j) * 100.
    853. 

  853.               grid%shdmax(i,j) = grid%shdmax(i,j) * 100.
    854. 

  854.               grid%shdmin(i,j) = grid%shdmin(i,j) * 100.
    855. 

  855.               grid%vegfrc(I,J)=grid%vegfra(I,J)
    856. 

  856.            END DO
    857. 

  857.          END DO
    858. 

  858. 

  859.          !  The model expects the albedo fields as
    860. 

  860.          !  a fraction, not a percent.  Set the water values to 8%.
    861. 

  861. 

  862.          DO j = jts, MIN(jte,jde-1)
    863. 

  863.            DO i = its, MIN(ite,ide-1)
    864. 

  864.               if (grid%albbck(i,j) .lt. 5.) then
    865. 

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

  866.                   CALL wrf_debug(10,message)
    867. 

  867.                   grid%albbck(I,J)=8.
    868. 

  868.               endif
    869. 

  869.               grid%albbck(i,j) = grid%albbck(i,j) / 100.
    870. 

  870.               grid%snoalb(i,j) = grid%snoalb(i,j) / 100.
    871. 

  871.               IF ( grid%landmask(i,j) .LT. 0.5 ) THEN
    872. 

  872.                  grid%albbck(i,j) = 0.08
    873. 

  873.                  grid%snoalb(i,j) = 0.08
    874. 

  874.               END IF
    875. 

  875.               grid%albase(i,j)=grid%albbck(i,j)
    876. 

  876.               grid%mxsnal(i,j)=grid%snoalb(i,j)
    877. 

  877.            END DO
    878. 

  878.          END DO
    879. 

  879. 

  880.          endif
    881. 

  881. 

  882. #if defined(HWRF)
    883. 

  883.        if(.not.grid%use_prep_hybrid) then
    884. 

  884. #endif
    885. 

  885. !  new deallocs
    886. 

  886.         DEALLOCATE(p3d_out,p3dv_out,p3dv_in)
    887. 

  887. #if defined(HWRF)
    888. 

  888.        end if
    889. 

  889. #endif
    890. 

  890. 

  891.      END IF     !   <----- END OF VERTICAL INTERPOLATION PART ---->
    892. 

  892. 

  893. 

  894. !! compute SST at each time if updating SST
    895. 

  895.         if (config_flags%sst_update == 1) then
    896. 

  896. 

  897.          DO j = jts, MIN(jde-1,jte)
    898. 

  898.             DO i = its, MIN(ide-1,ite)
    899. 

  899. 

  900.         if (grid%SM(I,J) .lt. 0.5) then
    901. 

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

  902.         endif
    903. 

  903. 

  904.         if (grid%SM(I,J) .gt. 0.5) then
    905. 

  905.             grid%SST(I,J)=grid%NMM_TSK(I,J)
    906. 

  906.             grid%NMM_TSK(I,J)=0.
    907. 

  907.         endif
    908. 

  908. 

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

  910.              (grid%NMM_TSK(I,J)+grid%SST(I,J)) .gt. 350. ) THEN
    911. 

  911.           write(message,*) 'TSK, SST trouble at : ', I,J
    912. 

  912.           CALL wrf_message(message)
    913. 

  913.           write(message,*) 'SM, NMM_TSK,SST ', grid%SM(I,J),grid%NMM_TSK(I,J),grid%SST(I,J)
    914. 

  914.           CALL wrf_message(message)
    915. 

  915.         ENDIF
    916. 

  916. 

  917.             ENDDO
    918. 

  918.          ENDDO
    919. 

  919. 

  920.         endif ! sst_update test
    921. 

  921. 

  922.         if (internal_time_loop .eq. 1) then
    923. 

  923. 

  924. !!! weasd has "snow water equivalent" in mm
    925. 

  925. 

  926.        DO j = jts, MIN(jte,jde-1)
    927. 

  927.          DO i = its, MIN(ite,ide-1)
    928. 

  928. 

  929.       IF(grid%sm(I,J).GT.0.9) THEN
    930. 

  930. 

  931.        IF (grid%xice(I,J) .gt. 0) then
    932. 

  932.          grid%si(I,J)=1.0
    933. 

  933.        ENDIF
    934. 

  934. 

  935. !  SEA
    936. 

  936.               grid%epsr(I,J)=.97
    937. 

  937.               grid%embck(I,J)=.97
    938. 

  938.               grid%gffc(I,J)=0.
    939. 

  939.               grid%albedo(I,J)=.06
    940. 

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

  941.               IF(grid%si (I,J).GT.0.    ) THEN
    942. 

  942. !  SEA-ICE
    943. 

  943.                  grid%sm(I,J)=0.
    944. 

  944.                  grid%si(I,J)=0.
    945. 

  945.                  grid%sice(I,J)=1.
    946. 

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

  947.                  grid%albedo(I,J)=.60
    948. 

  948.                  grid%albase(I,J)=.60
    949. 

  949.               ENDIF
    950. 

  950.            ELSE
    951. 

  951. 

  952.         grid%si(I,J)=5.0*grid%weasd(I,J)/1000.
    953. 

  953. ! LAND
    954. 

  954.         grid%epsr(I,J)=1.0
    955. 

  955.         grid%embck(I,J)=1.0
    956. 

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

  957.         grid%sice(I,J)=0.
    958. 

  958.         grid%sno(I,J)=grid%si(I,J)*.20
    959. 

  959.            ENDIF
    960. 

  960.         ENDDO
    961. 

  961.         ENDDO
    962. 

  962. 

  963. ! DETERMINE grid%albedo OVER LAND
    964. 

  964.        DO j = jts, MIN(jte,jde-1)
    965. 

  965.          DO i = its, MIN(ite,ide-1)
    966. 

  966.           IF(grid%sm(I,J).LT.0.9.AND.grid%sice(I,J).LT.0.9) THEN
    967. 

  967. ! SNOWFREE albedo
    968. 

  968.             IF ( (grid%sno(I,J) .EQ. 0.0) .OR. &
    969. 

  969.                 (grid%albase(I,J) .GE. grid%mxsnal(I,J) ) ) THEN
    970. 

  970.               grid%albedo(I,J) = grid%albase(I,J)
    971. 

  971.             ELSE
    972. 

  972. ! MODIFY albedo IF SNOWCOVER:
    973. 

  973. ! BELOW SNOWDEPTH THRESHOLD...
    974. 

  974.               IF (grid%sno(I,J) .LT. SNUP) THEN
    975. 

  975.                 RSNOW = grid%sno(I,J)/SNUP
    976. 

  976.                 SNOFAC = 1. - ( EXP(-SALP*RSNOW) - RSNOW*EXP(-SALP))
    977. 

  977. ! ABOVE SNOWDEPTH THRESHOLD...
    978. 

  978.               ELSE
    979. 

  979.                 SNOFAC = 1.0
    980. 

  980.               ENDIF
    981. 

  981. ! CALCULATE grid%albedo ACCOUNTING FOR SNOWDEPTH AND VGFRCK
    982. 

  982.               grid%albedo(I,J) = grid%albase(I,J) &
    983. 

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

  984.             ENDIF
    985. 

  985.           END IF
    986. 

  986.           grid%si(I,J)=5.0*grid%weasd(I,J)
    987. 

  987.           grid%sno(I,J)=grid%weasd(I,J)
    988. 

  988. 

  989. !!  convert vegfra
    990. 

  990.           grid%vegfra(I,J)=grid%vegfra(I,J)*100.
    991. 

  991. !
    992. 

  992.         ENDDO
    993. 

  993.       ENDDO
    994. 

  994. 

  995. #ifdef DM_PARALLEL
    996. 

  996. 

  997.         ALLOCATE(SM_G(IDS:IDE,JDS:JDE),SICE_G(IDS:IDE,JDS:JDE))
    998. 

  998. 

  999.         CALL WRF_PATCH_TO_GLOBAL_REAL( grid%sice(IMS,JMS)           &
    1000. 

  1000.      &,                                SICE_G,grid%DOMDESC         &
    1001. 

  1001.      &,                               'z','xy'                       &
    1002. 

  1002.      &,                                IDS,IDE-1,JDS,JDE-1,1,1          &
    1003. 

  1003.      &,                                IMS,IME,JMS,JME,1,1              &
    1004. 

  1004.      &,                                ITS,ITE,JTS,JTE,1,1 )
    1005. 

  1005. 

  1006.         CALL WRF_PATCH_TO_GLOBAL_REAL( grid%sm(IMS,JMS)           &
    1007. 

  1007.      &,                                SM_G,grid%DOMDESC         &
    1008. 

  1008.      &,                               'z','xy'                       &
    1009. 

  1009.      &,                                IDS,IDE-1,JDS,JDE-1,1,1          &
    1010. 

  1010.      &,                                IMS,IME,JMS,JME,1,1              &
    1011. 

  1011.      &,                                ITS,ITE,JTS,JTE,1,1 )
    1012. 

  1012. 

  1013. 

  1014.         IF (WRF_DM_ON_MONITOR()) THEN
    1015. 

  1015. 

  1016.   637   format(40(f3.0,1x))
    1017. 

  1017. 

  1018.         allocate(IHE_G(JDS:JDE-1),IHW_G(JDS:JDE-1))
    1019. 

  1019.        DO j = JDS, JDE-1
    1020. 

  1020.           IHE_G(J)=MOD(J+1,2)
    1021. 

  1021.           IHW_G(J)=IHE_G(J)-1
    1022. 

  1022.        ENDDO
    1023. 

  1023. 

  1024.       DO ITER=1,10
    1025. 

  1025.        DO j = jds+1, (jde-1)-1
    1026. 

  1026.          DO i = ids+1, (ide-1)-1
    1027. 

  1027. 

  1028. ! any sea ice around point in question?
    1029. 

  1029. 

  1030.         IF (SM_G(I,J) .ge. 0.9) THEN
    1031. 

  1031.           SEAICESUM=SICE_G(I+IHE_G(J),J+1)+SICE_G(I+IHW_G(J),J+1)+ &
    1032. 

  1032.                     SICE_G(I+IHE_G(J),J-1)+SICE_G(I+IHW_G(J),J-1)
    1033. 

  1033.           IF (SEAICESUM .ge. 1. .and. SEAICESUM .lt. 3.) THEN
    1034. 

  1034. 

  1035.             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. &
    1036. 

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

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

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

  1039. 

  1040. !             HAVE SEA ICE AND A SURROUNDING LAND POINT - CONVERT TO SEA ICE
    1041. 

  1041. 

  1042.               write(message,*) 'making seaice (1): ', I,J
    1043. 

  1043.               CALL wrf_debug(100,message)
    1044. 

  1044.               SICE_G(I,J)=1.0
    1045. 

  1045.               SM_G(I,J)=0.
    1046. 

  1046. 

  1047.             ENDIF
    1048. 

  1048. 

  1049.           ELSEIF (SEAICESUM .ge. 3) THEN
    1050. 

  1050. 

  1051. !       WATER POINT SURROUNDED BY ICE  - CONVERT TO SEA ICE
    1052. 

  1052. 

  1053.             write(message,*) 'making seaice (2): ', I,J
    1054. 

  1054.             CALL wrf_debug(100,message)
    1055. 

  1055.             SICE_G(I,J)=1.0
    1056. 

  1056.             SM_G(I,J)=0.
    1057. 

  1057.           ENDIF
    1058. 

  1058. 

  1059.         ENDIF
    1060. 

  1060. 

  1061.         ENDDO
    1062. 

  1062.        ENDDO
    1063. 

  1063.       ENDDO
    1064. 

  1064. 

  1065.         ENDIF
    1066. 

  1066. 

  1067.         CALL WRF_GLOBAL_TO_PATCH_REAL( SICE_G, grid%sice           &
    1068. 

  1068.      &,                                grid%DOMDESC         &
    1069. 

  1069.      &,                               'z','xy'                       &
    1070. 

  1070.      &,                                IDS,IDE-1,JDS,JDE-1,1,1          &
    1071. 

  1071.      &,                                IMS,IME,JMS,JME,1,1              &
    1072. 

  1072.      &,                                ITS,ITE,JTS,JTE,1,1 )
    1073. 

  1073. 

  1074.         CALL WRF_GLOBAL_TO_PATCH_REAL( SM_G,grid%sm           &
    1075. 

  1075.      &,                                grid%DOMDESC         &
    1076. 

  1076.      &,                               'z','xy'                       &
    1077. 

  1077.      &,                                IDS,IDE-1,JDS,JDE-1,1,1          &
    1078. 

  1078.      &,                                IMS,IME,JMS,JME,1,1              &
    1079. 

  1079.      &,                                ITS,ITE,JTS,JTE,1,1 )
    1080. 

  1080. 

  1081.         IF (WRF_DM_ON_MONITOR()) THEN
    1082. 

  1082. #if defined(HWRF)
    1083. 

  1083.           ! SM_G is still needed for the high-res grid
    1084. 

  1084. #else
    1085. 

  1085.           DEALLOCATE(SM_G)
    1086. 

  1086. #endif
    1087. 

  1087.           deallocate(SICE_G)
    1088. 

  1088.         DEALLOCATE(IHE_G,IHW_G)
    1089. 

  1089. 

  1090.         ENDIF
    1091. 

  1091. 

  1092. !        write(message,*) 'revised sea ice on patch'
    1093. 

  1093. !        CALL wrf_debug(100,message)
    1094. 

  1094. !        DO J=JTE,JTS,-(((JTE-JTS)/25)+1)
    1095. 

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

  1096. !          CALL wrf_debug(100,message)
    1097. 

  1097. !        END DO
    1098. 

  1098. 

  1099. #else
    1100. 

  1100. ! serial sea ice reprocessing
    1101. 

  1101.         allocate(IHE(JDS:JDE-1),IHW(JDS:JDE-1))
    1102. 

  1102. 

  1103.        DO j = jts, MIN(jte,jde-1)
    1104. 

  1104.           IHE(J)=MOD(J+1,2)
    1105. 

  1105.           IHW(J)=IHE(J)-1
    1106. 

  1106.        ENDDO
    1107. 

  1107. 

  1108.       DO ITER=1,10
    1109. 

  1109.        DO j = jts+1, MIN(jte,jde-1)-1
    1110. 

  1110.          DO i = its+1, MIN(ite,ide-1)-1
    1111. 

  1111. 

  1112. ! any sea ice around point in question?
    1113. 

  1113. 

  1114.         IF (grid%sm(I,J) .gt. 0.9) THEN
    1115. 

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

  1116.                   grid%sice(I+IHE(J),J-1)+grid%sice(I+IHW(J),J-1)
    1117. 

  1117.           IF (SEAICESUM .ge. 1. .and. SEAICESUM .lt. 3.) THEN
    1118. 

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

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

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

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

  1122. 

  1123. !       HAVE SEA ICE AND A SURROUNDING LAND POINT - CONVERT TO SEA ICE
    1124. 

  1124.               grid%sice(I,J)=1.0
    1125. 

  1125.               grid%sm(I,J)=0.
    1126. 

  1126.             ENDIF
    1127. 

  1127.           ELSEIF (SEAICESUM .ge. 3) THEN
    1128. 

  1128. !       WATER POINT SURROUNDED BY ICE  - CONVERT TO SEA ICE
    1129. 

  1129.         grid%sice(I,J)=1.0
    1130. 

  1130.         grid%sm(I,J)=0.
    1131. 

  1131.           ENDIF
    1132. 

  1132.         ENDIF
    1133. 

  1133. 

  1134.         ENDDO
    1135. 

  1135.        ENDDO
    1136. 

  1136.       ENDDO
    1137. 

  1137. 

  1138.         DEALLOCATE(IHE,IHW)
    1139. 

  1139. #endif
    1140. 

  1140. 

  1141. ! this block meant to guarantee land/sea agreement between sm and landmask
    1142. 

  1142. 

  1143.        DO j = jts, MIN(jte,jde-1)
    1144. 

  1144.          DO i = its, MIN(ite,ide-1)
    1145. 

  1145. 

  1146.           IF (grid%sm(I,J) .gt. 0.5) THEN
    1147. 

  1147.                 grid%landmask(I,J)=0.0
    1148. 

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

  1149.                 grid%landmask(I,J)=0.0
    1150. 

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

  1151.                 grid%landmask(I,J)=1.0
    1152. 

  1152.           ELSE
    1153. 

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

  1154.                 CALL wrf_message(message)
    1155. 

  1155.                 grid%landmask(I,J)=0.0
    1156. 

  1156.           ENDIF
    1157. 

  1157. !
    1158. 

  1158.         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
    1159. 

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

  1160.            CALL wrf_message(message)
    1161. 

  1161.            grid%nmm_tsk(I,J)=grid%sst(I,J)
    1162. 

  1162.            grid%sst(I,J)=0.
    1163. 

  1163.         endif
    1164. 

  1164. 

  1165.         ENDDO
    1166. 

  1166.       ENDDO
    1167. 

  1167. 

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

  1169.       !  for the bottom level of the soil temps.
    1170. 

  1170. 

  1171.       IF      ( ( model_config_rec%sf_surface_physics(grid%id) .EQ. 1 ) .AND. &
    1172. 

  1172.                 ( flag_st000010 .EQ. 1 ) ) THEN
    1173. 

  1173.          DO j = jts , MIN(jde-1,jte)
    1174. 

  1174.             DO i = its , MIN(ide-1,ite)
    1175. 

  1175.                grid%soiltb(i,j) = grid%st000010(i,j)
    1176. 

  1176.             END DO
    1177. 

  1177.          END DO
    1178. 

  1178.       END IF
    1179. 

  1179. 

  1180.   !  Adjust the various soil temperature values depending on the difference in
    1181. 

  1181.   !  in elevation between the current model's elevation and the incoming data's
    1182. 

  1182.   !  orography.
    1183. 

  1183. 

  1184.       IF ( ( flag_toposoil .EQ. 1 ) ) THEN
    1185. 

  1185. 

  1186.         ALLOCATE(HT(ims:ime,jms:jme))
    1187. 

  1187. 

  1188.         DO J=jms,jme
    1189. 

  1189.           DO I=ims,ime
    1190. 

  1190.               HT(I,J)=grid%fis(I,J)/9.81
    1191. 

  1191.           END DO
    1192. 

  1192.         END DO
    1193. 

  1193. 

  1194. !       if (maxval(grid%toposoil) .gt. 100.) then
    1195. 

  1195. !
    1196. 

  1196. !  Being avoided.   Something to revisit eventually.
    1197. 

  1197. !
    1198. 

  1198. !1219 might be simply a matter of including toposoil
    1199. 

  1199. !
    1200. 

  1200. !    CODE NOT TESTED AT NCEP USING THIS FUNCTIONALITY,
    1201. 

  1201. !    SO TO BE SAFE WILL AVOID FOR RETRO RUNS.
    1202. 

  1202. !
    1203. 

  1203. !        CALL adjust_soil_temp_new ( grid%soiltb , 2 , &
    1204. 

  1204. !                       grid%nmm_tsk , ht , grid%toposoil , grid%landmask, flag_toposoil , &
    1205. 

  1205. !                       grid%st000010 , st010040 , st040100 , st100200 , st010200 , &
    1206. 

  1206. !                       flag_st000010 , flag_st010040 , flag_st040100 , &
    1207. 

  1207. !                       flag_st100200 , flag_st010200 , &
    1208. 

  1208. !                       soilt000 , soilt005 , soilt020 , soilt040 , &
    1209. 

  1209. !                       soilt160 , soilt300 , &
    1210. 

  1210. !                       flag_soilt000 , flag_soilt005 , flag_soilt020 , &
    1211. 

  1211. !                       flag_soilt040 , flag_soilt160 , flag_soilt300 , &
    1212. 

  1212. !                       ids , ide , jds , jde , kds , kde , &
    1213. 

  1213. !                       ims , ime , jms , jme , kms , kme , &
    1214. 

  1214. !                       its , ite , jts , jte , kts , kte )
    1215. 

  1215. !       endif
    1216. 

  1216. 

  1217.       END IF
    1218. 

  1218. 

  1219.       !  Process the LSM data.
    1220. 

  1220. 

  1221.       !  surface_input_source=1 => use data from static file
    1222. 

  1222.       !                            (fractional category as input)
    1223. 

  1223.       !  surface_input_source=2 => use data from grib file
    1224. 

  1224.       !                            (dominant category as input)
    1225. 

  1225. 

  1226.       IF ( config_flags%surface_input_source .EQ. 1 ) THEN
    1227. 

  1227.          grid%vegcat (its,jts) = 0
    1228. 

  1228.          grid%soilcat(its,jts) = 0
    1229. 

  1229.       END IF
    1230. 

  1230. 

  1231.       !  Generate the vegetation and soil category information
    1232. 

  1232.       !  from the fractional input
    1233. 

  1233.       !  data, or use the existing dominant category fields if they exist.
    1234. 

  1234. 

  1235.       IF ((grid%soilcat(its,jts) .LT. 0.5) .AND. (grid%vegcat(its,jts) .LT. 0.5)) THEN
    1236. 

  1236. 

  1237.          num_veg_cat      = SIZE ( grid%landusef_gc , DIM=3 )
    1238. 

  1238.          num_soil_top_cat = SIZE ( grid%soilctop_gc , DIM=3 )
    1239. 

  1239.          num_soil_bot_cat = SIZE ( grid%soilcbot_gc , DIM=3 )
    1240. 

  1240. 

  1241.         do J=JMS,JME
    1242. 

  1242.         do K=1,num_veg_cat
    1243. 

  1243.         do I=IMS,IME
    1244. 

  1244.            grid%landusef(I,K,J)=grid%landusef_gc(I,J,K)
    1245. 

  1245.         enddo
    1246. 

  1246.         enddo
    1247. 

  1247.         enddo
    1248. 

  1248. 

  1249.         do J=JMS,JME
    1250. 

  1250.         do K=1,num_soil_top_cat
    1251. 

  1251.         do I=IMS,IME
    1252. 

  1252.            grid%soilctop(I,K,J)=grid%soilctop_gc(I,J,K)
    1253. 

  1253.         enddo
    1254. 

  1254.         enddo
    1255. 

  1255.         enddo
    1256. 

  1256. 

  1257.         do J=JMS,JME
    1258. 

  1258.         do K=1,num_soil_bot_cat
    1259. 

  1259.         do I=IMS,IME
    1260. 

  1260.            grid%soilcbot(I,K,J)=grid%soilcbot_gc(I,J,K)
    1261. 

  1261.         enddo
    1262. 

  1262.         enddo
    1263. 

  1263.         enddo
    1264. 

  1264. 

  1265. !       grid%sm (1=water, 0=land)
    1266. 

  1266. !       grid%landmask(0=water, 1=land)
    1267. 

  1267. 

  1268. 

  1269.         write(message,*) 'landmask into process_percent_cat_new'
    1270. 

  1270. 

  1271.         CALL wrf_debug(1,message)
    1272. 

  1272.         do J=JTE,JTS,-(((JTE-JTS)/20)+1)
    1273. 

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

  1274.         CALL wrf_debug(1,message)
    1275. 

  1275.         enddo
    1276. 

  1276.   641   format(25(f3.0,1x))
    1277. 

  1277. 

  1278.          CALL process_percent_cat_new ( grid%landmask , &
    1279. 

  1279.                          grid%landusef , grid%soilctop , grid%soilcbot , &
    1280. 

  1280.                          grid%isltyp , grid%ivgtyp , &
    1281. 

  1281.                          num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
    1282. 

  1282.                          ids , ide , jds , jde , kds , kde , &
    1283. 

  1283.                          ims , ime , jms , jme , kms , kme , &
    1284. 

  1284.                          its , ite , jts , jte , kts , kte , &
    1285. 

  1285.                          model_config_rec%iswater(grid%id) )
    1286. 

  1286. 

  1287.          DO j = jts , MIN(jde-1,jte)
    1288. 

  1288.             DO i = its , MIN(ide-1,ite)
    1289. 

  1289.                grid%vegcat(i,j)  = grid%ivgtyp(i,j)
    1290. 

  1290.                grid%soilcat(i,j) = grid%isltyp(i,j)
    1291. 

  1291.             END DO
    1292. 

  1292.          END DO
    1293. 

  1293. 

  1294.        ELSE
    1295. 

  1295. 

  1296.          !  Do we have dominant soil and veg data from the input already?
    1297. 

  1297. 

  1298.          IF ( grid%soilcat(its,jts) .GT. 0.5 ) THEN
    1299. 

  1299.             DO j = jts, MIN(jde-1,jte)
    1300. 

  1300.                DO i = its, MIN(ide-1,ite)
    1301. 

  1301.                   grid%isltyp(i,j) = NINT( grid%soilcat(i,j) )
    1302. 

  1302.                END DO
    1303. 

  1303.             END DO
    1304. 

  1304.          END IF
    1305. 

  1305.          IF ( grid%vegcat(its,jts) .GT. 0.5 ) THEN
    1306. 

  1306.             DO j = jts, MIN(jde-1,jte)
    1307. 

  1307.                DO i = its, MIN(ide-1,ite)
    1308. 

  1308.                   grid%ivgtyp(i,j) = NINT( grid%vegcat(i,j) )
    1309. 

  1309.                END DO
    1310. 

  1310.             END DO
    1311. 

  1311.          END IF
    1312. 

  1312. 

  1313.        ENDIF
    1314. 

  1314. 

  1315.         DO j = jts, MIN(jde-1,jte)
    1316. 

  1316.             DO i = its, MIN(ide-1,ite)
    1317. 

  1317. 

  1318.         IF (grid%sice(I,J) .lt. 0.1) THEN
    1319. 

  1319.           IF (grid%landmask(I,J) .gt. 0.5 .and. grid%sm(I,J) .gt. 0.5) THEN
    1320. 

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

  1321.                                            I,J,grid%landmask(I,J),grid%sm(I,J)
    1322. 

  1322.                 CALL wrf_message(message)
    1323. 

  1323.                 grid%sm(I,J)=0.
    1324. 

  1324.           ELSEIF (grid%landmask(I,J) .lt. 0.5 .and. grid%sm(I,J) .lt. 0.5) THEN
    1325. 

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

  1326.                                            I,J, grid%landmask(I,J),grid%sm(I,J)
    1327. 

  1327.                 CALL wrf_message(message)
    1328. 

  1328.                 grid%sm(I,J)=1.
    1329. 

  1329.           ENDIF
    1330. 

  1330.         ELSE
    1331. 

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

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

  1333.           ENDIF
    1334. 

  1334.         ENDIF
    1335. 

  1335. 

  1336.            ENDDO
    1337. 

  1337.         ENDDO
    1338. 

  1338. 

  1339.          DO j = jts, MIN(jde-1,jte)
    1340. 

  1340.             DO i = its, MIN(ide-1,ite)
    1341. 

  1341. 

  1342.         if (grid%sice(I,J) .gt. 0.9) then
    1343. 

  1343.         grid%isltyp(I,J)=16
    1344. 

  1344.         grid%ivgtyp(I,J)=24
    1345. 

  1345.         endif
    1346. 

  1346. 

  1347.             ENDDO
    1348. 

  1348.          ENDDO
    1349. 

  1349. 

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

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

  1352. 

  1353.         if (grid%sm(I,J) .lt. 0.5) then
    1354. 

  1354.             grid%sst(I,J)=0.
    1355. 

  1355.         endif
    1356. 

  1356. 

  1357.         if (grid%sm(I,J) .gt. 0.5) then
    1358. 

  1358.           if (grid%sst(I,J) .lt. 0.1) then
    1359. 

  1359.             grid%sst(I,J)=grid%nmm_tsk(I,J)
    1360. 

  1360.           endif
    1361. 

  1361.             grid%nmm_tsk(I,J)=0.
    1362. 

  1362.         endif
    1363. 

  1363. 

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

  1365.              (grid%nmm_tsk(I,J)+grid%sst(I,J)) .gt. 350. ) THEN
    1366. 

  1366.           write(message,*) 'TSK, sst trouble at : ', I,J
    1367. 

  1367.           CALL wrf_message(message)
    1368. 

  1368.           write(message,*) 'sm, nmm_tsk,sst ', grid%sm(I,J),grid%nmm_tsk(I,J),grid%sst(I,J)
    1369. 

  1369.           CALL wrf_message(message)
    1370. 

  1370.         ENDIF
    1371. 

  1371. 

  1372.             ENDDO
    1373. 

  1373.          ENDDO
    1374. 

  1374. 

  1375.         write(message,*) 'grid%sm'
    1376. 

  1376.         CALL wrf_message(message)
    1377. 

  1377. 

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

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

  1380.           CALL wrf_message(message)
    1381. 

  1381.         END DO
    1382. 

  1382. 

  1383.         write(message,*) 'sst/nmm_tsk'
    1384. 

  1384.         CALL wrf_debug(10,message)
    1385. 

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

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

  1387.           CALL wrf_debug(10,message)
    1388. 

  1388.         END DO
    1389. 

  1389. 

  1390.   635   format(20(f5.1,1x))
    1391. 

  1391. 

  1392.          DO j = jts, MIN(jde-1,jte)
    1393. 

  1393.             DO i = its, MIN(ide-1,ite)
    1394. 

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

  1395.                   grid%soiltb(i,j) = grid%sst(i,j)
    1396. 

  1396.                ELSE IF (  grid%landmask(i,j) .GT. 0.5 ) THEN
    1397. 

  1397.                   grid%soiltb(i,j) = grid%nmm_tsk(i,j)
    1398. 

  1398.                END IF
    1399. 

  1399.             END DO
    1400. 

  1400.          END DO
    1401. 

  1401. 

  1402. !      END IF
    1403. 

  1403. 

  1404.    !  Land use categories, dominant soil and vegetation types (if available).
    1405. 

  1405. 

  1406. !       allocate(grid%lu_index(ims:ime,jms:jme))
    1407. 

  1407. 

  1408.           DO j = jts, MIN(jde-1,jte)
    1409. 

  1409.             DO i = its, MIN(ide-1,ite)
    1410. 

  1410.                grid%lu_index(i,j) = grid%ivgtyp(i,j)
    1411. 

  1411.             END DO
    1412. 

  1412.           END DO
    1413. 

  1413. 

  1414.         if (flag_sst .eq. 1) log_flag_sst=.true.
    1415. 

  1415.         if (flag_sst .eq. 0) log_flag_sst=.false.
    1416. 

  1416. 

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

  1418.                                   size(st_input,dim=2),size(st_input,dim=3)
    1419. 

  1419.         CALL wrf_debug(100,message)
    1420. 

  1420. 

  1421. !        write(message,*) 'maxval st_input(1): ', maxval(st_input(:,1,:))
    1422. 

  1422. !          CALL wrf_message(message)
    1423. 

  1423. !        write(message,*) 'maxval st_input(2): ', maxval(st_input(:,2,:))
    1424. 

  1424. !          CALL wrf_message(message)
    1425. 

  1425. !        write(message,*) 'maxval st_input(3): ', maxval(st_input(:,3,:))
    1426. 

  1426. !          CALL wrf_message(message)
    1427. 

  1427. !        write(message,*) 'maxval st_input(4): ', maxval(st_input(:,4,:))
    1428. 

  1428. !          CALL wrf_message(message)
    1429. 

  1429. 

  1430. ! =============================================================
    1431. 

  1431. 

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

  1433. 

  1434.       TPH0=TPH0D*DTR
    1435. 

  1435.       WBD=-(((ide-1)-1)*grid%dlmd)
    1436. 

  1436.       WB= WBD*DTR
    1437. 

  1437.       SBD=-(((jde-1)/2)*grid%dphd)
    1438. 

  1438.       SB= SBD*DTR
    1439. 

  1439.       DLM=grid%dlmd*DTR
    1440. 

  1440.       DPH=grid%dphd*DTR
    1441. 

  1441.       TDLM=DLM+DLM
    1442. 

  1442.       TDPH=DPH+DPH
    1443. 

  1443.       WBI=WB+TDLM
    1444. 

  1444.       SBI=SB+TDPH
    1445. 

  1445.       EBI=WB+(ide-2)*TDLM
    1446. 

  1446.       ANBI=SB+(jde-2)*DPH
    1447. 

  1447.       STPH0=SIN(TPH0)
    1448. 

  1448.       CTPH0=COS(TPH0)
    1449. 

  1449.       TSPH=3600./GRID%DT
    1450. 

  1450.          DO J=JTS,min(JTE,JDE-1)
    1451. 

  1451.            TLM=WB-TDLM+MOD(J,2)*DLM   !For velocity points on the E grid
    1452. 

  1452.            TPH=SB+float(J-1)*DPH
    1453. 

  1453.            STPH=SIN(TPH)
    1454. 

  1454.            CTPH=COS(TPH)
    1455. 

  1455.            DO I=ITS,MIN(ITE,IDE-1)
    1456. 

  1456. 

  1457.         if (I .eq. ITS) THEN
    1458. 

  1458.              TLM=TLM+TDLM*ITS
    1459. 

  1459.         else
    1460. 

  1460.              TLM=TLM+TDLM
    1461. 

  1461.         endif
    1462. 

  1462. 

  1463.              TERM1=(STPH0*CTPH*COS(TLM)+CTPH0*STPH)
    1464. 

  1464.              FP=TWOM*(TERM1)
    1465. 

  1465. ! jbao orig             grid%f(I,J)=0.5*GRID%DT*FP
    1466. 

  1466. ! jbao Coriolis correction for idealized!
    1467. 

  1467.              grid%f(I,J)=3.15656e-5*0.5*GRID%DT
    1468. 

  1468. ! jbao Coriolis correction for idealized!
    1469. 

  1469. 

  1470.            ENDDO
    1471. 

  1471.          ENDDO
    1472. 

  1472.          DO J=JTS,min(JTE,JDE-1)
    1473. 

  1473.            TLM=WB-TDLM+MOD(J+1,2)*DLM   !For mass points on the E grid
    1474. 

  1474.            TPH=SB+float(J-1)*DPH
    1475. 

  1475.            STPH=SIN(TPH)
    1476. 

  1476.            CTPH=COS(TPH)
    1477. 

  1477.            DO I=ITS,MIN(ITE,IDE-1)
    1478. 

  1478. 

  1479.         if (I .eq. ITS) THEN
    1480. 

  1480.              TLM=TLM+TDLM*ITS
    1481. 

  1481.         else
    1482. 

  1482.              TLM=TLM+TDLM
    1483. 

  1483.         endif
    1484. 

  1484. 

  1485.              TERM1=(STPH0*CTPH*COS(TLM)+CTPH0*STPH)
    1486. 

  1486.              TERM1=MIN(TERM1,1.0D0)
    1487. 

  1487.              TERM1=MAX(TERM1,-1.0D0)
    1488. 

  1488.              APH=ASIN(TERM1)
    1489. 

  1489.              TG_ALT(I,J)=TG0+TGA*COS(APH)-grid%fis(I,J)/3333.
    1490. 

  1490.            ENDDO
    1491. 

  1491.          ENDDO
    1492. 

  1492. 

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

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

  1495. !                  IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. &
    1496. 

  1496. !                         grid%sice(I,J) .eq. 0. ) THEN
    1497. 

  1497. !                     grid%tg(i,j) = grid%sst(i,j)
    1498. 

  1498. !                   ELSEIF (grid%sice(I,J) .eq. 1) THEN
    1499. 

  1499. !                     grid%tg(i,j) = 271.16
    1500. 

  1500. !                   END IF
    1501. 

  1501. 

  1502.         if (grid%tg(I,J) .lt. 200.) then   ! only use default TG_ALT definition if
    1503. 

  1503.                                       ! not getting TGROUND from grid%si
    1504. 

  1504.                 grid%tg(I,J)=TG_ALT(I,J)
    1505. 

  1505.         endif
    1506. 

  1506. 

  1507.        if (grid%tg(I,J) .lt. 200. .or. grid%tg(I,J) .gt. 320.) then
    1508. 

  1508.                write(message,*) 'problematic grid%tg point at : ', I,J
    1509. 

  1509.                CALL wrf_message( message )
    1510. 

  1510.        endif
    1511. 

  1511. 

  1512.         adum2d(i,j)=grid%nmm_tsk(I,J)+grid%sst(I,J)
    1513. 

  1513. 

  1514.                END DO
    1515. 

  1515.             END DO
    1516. 

  1516. 

  1517.         DEALLOCATE(TG_ALT)
    1518. 

  1518. 

  1519.         write(message,*) 'call process_soil_real with num_st_levels_input: ',  num_st_levels_input
    1520. 

  1520.         CALL wrf_message( message )
    1521. 

  1521. 

  1522. ! =============================================================
    1523. 

  1523. 

  1524.   CALL process_soil_real ( adum2d, grid%tg , &
    1525. 

  1525.      grid%landmask, grid%sst, &
    1526. 

  1526.      st_input, sm_input, sw_input, &
    1527. 

  1527.      st_levels_input , sm_levels_input , &
    1528. 

  1528.      sw_levels_input , &
    1529. 

  1529.      grid%sldpth , grid%dzsoil , grid%stc , grid%smc , grid%sh2o,  &
    1530. 

  1530.      flag_sst , flag_soilt000, flag_soilm000, &
    1531. 

  1531.      ids , ide , jds , jde , kds , kde , &
    1532. 

  1532.      ims , ime , jms , jme , kms , kme , &
    1533. 

  1533.      its , ite , jts , jte , kts , kte , &
    1534. 

  1534.      model_config_rec%sf_surface_physics(grid%id) , &
    1535. 

  1535.      model_config_rec%num_soil_layers ,  &
    1536. 

  1536.      model_config_rec%real_data_init_type , &
    1537. 

  1537.      num_st_levels_input , num_sm_levels_input , &
    1538. 

  1538.      num_sw_levels_input , &
    1539. 

  1539.      num_st_levels_alloc , num_sm_levels_alloc , &
    1540. 

  1540.      num_sw_levels_alloc )
    1541. 

  1541. 

  1542. ! =============================================================
    1543. 

  1543. 

  1544. !  Minimum soil values, residual, from RUC LSM scheme.
    1545. 

  1545. !  For input from Noah and using
    1546. 

  1546. !  RUC LSM scheme, this must be subtracted from the input
    1547. 

  1547. !  total soil moisture.  For  input RUC data and using the Noah LSM scheme,
    1548. 

  1548. !  this value must be added to the soil moisture_input.
    1549. 

  1549. 

  1550.        lqmi(1:num_soil_top_cat) = &
    1551. 

  1551.        (/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10,     &
    1552. 

  1552.          0.089, 0.095, 0.10,  0.070, 0.068, 0.078, 0.0,      &
    1553. 

  1553.          0.004, 0.065 /) !dusan , 0.020, 0.004, 0.008 /)
    1554. 

  1554. 

  1555. !  At the initial time we care about values of soil moisture and temperature,
    1556. 

  1556. !  other times are ignored by the model, so we ignore them, too.
    1557. 

  1557. 

  1558.           account_for_zero_soil_moisture : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
    1559. 

  1559. 

  1560.              CASE ( LSMSCHEME )
    1561. 

  1561.                 iicount = 0
    1562. 

  1562.                 IF      ( FLAG_SM000010 .EQ. 1 ) THEN
    1563. 

  1563.                    DO j = jts, MIN(jde-1,jte)
    1564. 

  1564.                       DO i = its, MIN(ide-1,ite)
    1565. 

  1565.                          IF ((grid%landmask(i,j).gt.0.5) .and. (grid%stc(i,1,j) .gt. 200) .and. &
    1566. 

  1566.                             (grid%stc(i,1,j) .lt. 400) .and. (grid%smc(i,1,j) .lt. 0.005)) then
    1567. 

  1567.                             write(message,*) 'Noah > Noah: bad soil moisture at i,j = ',i,j,grid%smc(i,:,j)
    1568. 

  1568.                             CALL wrf_message(message)
    1569. 

  1569.                             iicount = iicount + 1
    1570. 

  1570.                             grid%smc(i,:,j) = 0.005
    1571. 

  1571.                          END IF
    1572. 

  1572.                       END DO
    1573. 

  1573.                    END DO
    1574. 

  1574.                    IF ( iicount .GT. 0 ) THEN
    1575. 

  1575.                    write(message,*) 'Noah -> Noah: total number of small soil moisture locations= ',&
    1576. 

  1576.                                                                                         iicount
    1577. 

  1577.                    CALL wrf_message(message)
    1578. 

  1578.                    END IF
    1579. 

  1579.                 ELSE IF ( FLAG_SOILM000 .EQ. 1 ) THEN
    1580. 

  1580.                    DO j = jts, MIN(jde-1,jte)
    1581. 

  1581.                       DO i = its, MIN(ide-1,ite)
    1582. 

  1582.                          grid%smc(i,:,j) = grid%smc(i,:,j) + lqmi(grid%isltyp(i,j))
    1583. 

  1583.                       END DO
    1584. 

  1584.                    END DO
    1585. 

  1585.                    DO j = jts, MIN(jde-1,jte)
    1586. 

  1586.                       DO i = its, MIN(ide-1,ite)
    1587. 

  1587.                          IF ((grid%landmask(i,j).gt.0.5) .and. (grid%stc(i,1,j) .gt. 200) .and. &
    1588. 

  1588.                             (grid%stc(i,1,j) .lt. 400) .and. (grid%smc(i,1,j) .lt. 0.004)) then
    1589. 

  1589.                             write(message,*) 'RUC -> Noah: bad soil moisture at i,j = ' &
    1590. 

  1590.                                                                      ,i,j,grid%smc(i,:,j)
    1591. 

  1591.                             CALL wrf_message(message)
    1592. 

  1592.                             iicount = iicount + 1
    1593. 

  1593.                             grid%smc(i,:,j) = 0.004
    1594. 

  1594.                          END IF
    1595. 

  1595.                       END DO
    1596. 

  1596.                    END DO
    1597. 

  1597.                    IF ( iicount .GT. 0 ) THEN
    1598. 

  1598.                    write(message,*) 'RUC -> Noah: total number of small soil moisture locations = ',&
    1599. 

  1599.                                                                                        iicount
    1600. 

  1600.                    CALL wrf_message(message)
    1601. 

  1601.                    END IF
    1602. 

  1602.                 END IF
    1603. 

  1603.                CASE ( RUCLSMSCHEME )
    1604. 

  1604.                 iicount = 0
    1605. 

  1605.                 IF      ( FLAG_SM000010 .EQ. 1 ) THEN
    1606. 

  1606.                    DO j = jts, MIN(jde-1,jte)
    1607. 

  1607.                       DO i = its, MIN(ide-1,ite)
    1608. 

  1608.                          grid%smc(i,:,j) = MAX ( grid%smc(i,:,j) - lqmi(grid%isltyp(i,j)) , 0. )
    1609. 

  1609.                       END DO
    1610. 

  1610.                    END DO
    1611. 

  1611.                 ELSE IF ( FLAG_SOILM000 .EQ. 1 ) THEN
    1612. 

  1612.                    ! no op
    1613. 

  1613.                 END IF
    1614. 

  1614. 

  1615.           END SELECT account_for_zero_soil_moisture
    1616. 

  1616. 

  1617. !!!     zero out grid%nmm_tsk at water points again
    1618. 

  1618. 

  1619.          DO j = jts, MIN(jde-1,jte)
    1620. 

  1620.             DO i = its, MIN(ide-1,ite)
    1621. 

  1621.         if (grid%sm(I,J) .gt. 0.5) then
    1622. 

  1622.             grid%nmm_tsk(I,J)=0.
    1623. 

  1623.         endif
    1624. 

  1624.             END DO
    1625. 

  1625.          END DO
    1626. 

  1626. 

  1627. !!      check on grid%stc
    1628. 

  1628. 

  1629.           DO j = jts, MIN(jde-1,jte)
    1630. 

  1630.             DO i = its, MIN(ide-1,ite)
    1631. 

  1631. 

  1632.         IF (grid%sice(I,J) .gt. 0.9) then
    1633. 

  1633.           DO L = 1, grid%num_soil_layers
    1634. 

  1634.             grid%stc(I,L,J)=271.16    ! grid%tg value used by Eta/NMM
    1635. 

  1635.           END DO
    1636. 

  1636.         END IF
    1637. 

  1637. 

  1638.         IF (grid%sm(I,J) .gt. 0.9) then
    1639. 

  1639.           DO L = 1, grid%num_soil_layers
    1640. 

  1640.             grid%stc(I,L,J)=273.16    ! grid%tg value used by Eta/NMM
    1641. 

  1641.           END DO
    1642. 

  1642.         END IF
    1643. 

  1643. 

  1644.             END DO
    1645. 

  1645.           END DO
    1646. 

  1646. 

  1647.          DO j = jts, MIN(jde-1,jte)
    1648. 

  1648.             DO i = its, MIN(ide-1,ite)
    1649. 

  1649. 

  1650.         if (grid%sm(I,J) .lt. 0.1 .and. grid%stc(I,1,J) .lt. 0.1) THEN
    1651. 

  1651.           write(message,*) 'troublesome grid%sm,grid%stc,grid%smc value: ', I,J,grid%sm(I,J), grid%stc(I,1,J),grid%smc(I,1,J)
    1652. 

  1652.           CALL wrf_message(message)
    1653. 

  1653.         do JJ=J-1,J+1
    1654. 

  1654.         do L=1, grid%num_soil_layers
    1655. 

  1655.         do II=I-1,I+1
    1656. 

  1656. 

  1657. 	if (II .ge. its .and. II .le. MIN(ide-1,ite) .and. &
    1658. 

  1658.             JJ .ge. jts .and. JJ .le. MIN(jde-1,jte)) then
    1659. 

  1659. 

  1660.         grid%stc(I,L,J)=amax1(grid%stc(I,L,J),grid%stc(II,L,JJ))
    1661. 

  1661.         cur_smc=grid%smc(I,L,J)
    1662. 

  1662. 

  1663.         if ( grid%smc(II,L,JJ) .gt. 0.005 .and. grid%smc(II,L,JJ) .lt. 1.0) then
    1664. 

  1664. 		aposs_smc=grid%smc(II,L,JJ)
    1665. 

  1665. 

  1666.         if ( cur_smc .eq. 0 ) then
    1667. 

  1667.                 cur_smc=aposs_smc
    1668. 

  1668.                 grid%smc(I,L,J)=cur_smc
    1669. 

  1669.         else
    1670. 

  1670.                 cur_smc=amin1(cur_smc,aposs_smc)
    1671. 

  1671.                 cur_smc=amin1(cur_smc,aposs_smc)
    1672. 

  1672.                 grid%smc(I,L,J)=cur_smc
    1673. 

  1673.         endif
    1674. 

  1674. 	endif
    1675. 

  1675. 

  1676. 	endif ! bounds check
    1677. 

  1677. 

  1678.         enddo
    1679. 

  1679.         enddo
    1680. 

  1680.         enddo
    1681. 

  1681.         write(message,*) 'grid%stc, grid%smc(1) now: ',  grid%stc(I,1,J),grid%smc(I,1,J)
    1682. 

  1682.         CALL wrf_message(message)
    1683. 

  1683.         endif
    1684. 

  1684. 

  1685.         if (grid%stc(I,1,J) .lt. 0.1) then
    1686. 

  1686.           write(message,*) 'QUITTING DUE TO STILL troublesome grid%stc value: ', I,J, grid%stc(I,1,J),grid%smc(I,1,J)
    1687. 

  1687.           call wrf_error_fatal(message)
    1688. 

  1688.         endif
    1689. 

  1689. 

  1690.         ENDDO
    1691. 

  1691.         ENDDO
    1692. 

  1692. 

  1693. !hardwire soil stuff for time being
    1694. 

  1694. 

  1695. !       RTDPTH=0.
    1696. 

  1696. !       RTDPTH(1)=0.1
    1697. 

  1697. !       RTDPTH(2)=0.3
    1698. 

  1698. !       RTDPTH(3)=0.6
    1699. 

  1699. 

  1700. !       grid%sldpth=0.
    1701. 

  1701. !       grid%sldpth(1)=0.1
    1702. 

  1702. !       grid%sldpth(2)=0.3
    1703. 

  1703. !       grid%sldpth(3)=0.6
    1704. 

  1704. !       grid%sldpth(4)=1.0
    1705. 

  1705. 

  1706. !!! main body of nmm_specific starts here
    1707. 

  1707. !
    1708. 

  1708.         do J=jts,min(jte,jde-1)
    1709. 

  1709.         do I=its,min(ite,ide-1)
    1710. 

  1710.          grid%res(I,J)=1.
    1711. 

  1711.         enddo
    1712. 

  1712.         enddo
    1713. 

  1713. 

  1714. !! grid%hbm2
    1715. 

  1715. 

  1716.         grid%hbm2=0.
    1717. 

  1717. 

  1718.        do J=jts,min(jte,jde-1)
    1719. 

  1719.         do I=its,min(ite,ide-1)
    1720. 

  1720. 

  1721.         IF ( (J .ge. 3 .and. J .le. (jde-1)-2) .AND. &
    1722. 

  1722.              (I .ge. 2 .and. I .le. (ide-1)-2+mod(J,2)) ) THEN
    1723. 

  1723.        grid%hbm2(I,J)=1.
    1724. 

  1724.         ENDIF
    1725. 

  1725.        enddo
    1726. 

  1726.        enddo
    1727. 

  1727. 

  1728. !! grid%hbm3
    1729. 

  1729.         grid%hbm3=0.
    1730. 

  1730. 

  1731. !!      LOOP OVER LOCAL DIMENSIONS
    1732. 

  1732. 

  1733.        do J=jts,min(jte,jde-1)
    1734. 

  1734.           grid%ihwg(J)=mod(J+1,2)-1
    1735. 

  1735.           IF (J .ge. 4 .and. J .le. (jde-1)-3) THEN
    1736. 

  1736.             IHL=(ids+1)-grid%ihwg(J)
    1737. 

  1737.             IHH=(ide-1)-2
    1738. 

  1738.             do I=its,min(ite,ide-1)
    1739. 

  1739.               IF (I .ge. IHL  .and. I .le. IHH) grid%hbm3(I,J)=1.
    1740. 

  1740.             enddo
    1741. 

  1741.           ENDIF
    1742. 

  1742.         enddo
    1743. 

  1743. 

  1744. !! grid%vbm2
    1745. 

  1745. 

  1746.        grid%vbm2=0.
    1747. 

  1747. 

  1748.        do J=jts,min(jte,jde-1)
    1749. 

  1749.        do I=its,min(ite,ide-1)
    1750. 

  1750. 

  1751.         IF ( (J .ge. 3 .and. J .le. (jde-1)-2)  .AND.  &
    1752. 

  1752.              (I .ge. 2 .and. I .le. (ide-1)-1-mod(J,2)) ) THEN
    1753. 

  1753. 

  1754.            grid%vbm2(I,J)=1.
    1755. 

  1755. 

  1756.         ENDIF
    1757. 

  1757. 

  1758.        enddo
    1759. 

  1759.        enddo
    1760. 

  1760. 

  1761. !! grid%vbm3
    1762. 

  1762. 

  1763.         grid%vbm3=0.
    1764. 

  1764. 

  1765.        do J=jts,min(jte,jde-1)
    1766. 

  1766.        do I=its,min(ite,ide-1)
    1767. 

  1767. 

  1768.         IF ( (J .ge. 4 .and. J .le. (jde-1)-3)  .AND.  &
    1769. 

  1769.              (I .ge. 3-mod(J,2) .and. I .le. (ide-1)-2) ) THEN
    1770. 

  1770.          grid%vbm3(I,J)=1.
    1771. 

  1771.         ENDIF
    1772. 

  1772. 

  1773.        enddo
    1774. 

  1774.        enddo
    1775. 

  1775. 

  1776.       COAC=model_config_rec%coac(grid%id)
    1777. 

  1777.       CODAMP=model_config_rec%codamp(grid%id)
    1778. 

  1778. 

  1779.       DTAD=1.0
    1780. 

  1780. !       IDTCF=DTCF, IDTCF=4
    1781. 

  1781.       DTCF=4.0 ! used?
    1782. 

  1782. 

  1783.       grid%dy_nmm=ERAD*DPH
    1784. 

  1784.       grid%cpgfv=-GRID%DT/(48.*grid%dy_nmm)
    1785. 

  1785.       grid%en= GRID%DT/( 4.*grid%dy_nmm)*DTAD
    1786. 

  1786.       grid%ent=GRID%DT/(16.*grid%dy_nmm)*DTAD
    1787. 

  1787. 

  1788.         DO J=jts,nnyp
    1789. 

  1789.          KHL2(J)=(IDE-1)*(J-1)-(J-1)/2+2
    1790. 

  1790.          KVL2(J)=(IDE-1)*(J-1)-J/2+2
    1791. 

  1791.          KHH2(J)=(IDE-1)*J-J/2-1
    1792. 

  1792.          KVH2(J)=(IDE-1)*J-(J+1)/2-1
    1793. 

  1793.         ENDDO
    1794. 

  1794. 

  1795.         TPH=SB-DPH
    1796. 

  1796. 

  1797.         DO J=jts,min(jte,jde-1)
    1798. 

  1798.          TPH=SB+float(J-1)*DPH
    1799. 

  1799.          DXP=ERAD*DLM*COS(TPH)
    1800. 

  1800.          DXJ(J)=DXP
    1801. 

  1801.          WPDARJ(J)=-W_NMM * &
    1802. 

  1802.      ((ERAD*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+grid%dy_nmm**2)/ &
    1803. 

  1803.                    (GRID%DT*32.*DXP*grid%dy_nmm)
    1804. 

  1804. 

  1805.          CPGFUJ(J)=-GRID%DT/(48.*DXP)
    1806. 

  1806.          CURVJ(J)=.5*GRID%DT*TAN(TPH)/ERAD
    1807. 

  1807.          FCPJ(J)=GRID%DT/(CP*192.*DXP*grid%dy_nmm)
    1808. 

  1808.          FDIVJ(J)=1./(12.*DXP*grid%dy_nmm)
    1809. 

  1809. !         EMJ(J)= GRID%DT/( 4.*DXP)*DTAD
    1810. 

  1810. !         EMTJ(J)=GRID%DT/(16.*DXP)*DTAD
    1811. 

  1811.          FADJ(J)=-GRID%DT/(48.*DXP*grid%dy_nmm)*DTAD
    1812. 

  1812.          ACDT=GRID%DT*SQRT((ERAD*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+grid%dy_nmm**2)
    1813. 

  1813.          CDDAMP=CODAMP*ACDT
    1814. 

  1814.          HDACJ(J)=COAC*ACDT/(4.*DXP*grid%dy_nmm)
    1815. 

  1815.          DDMPUJ(J)=CDDAMP/DXP
    1816. 

  1816.          DDMPVJ(J)=CDDAMP/grid%dy_nmm
    1817. 

  1817.         ENDDO
    1818. 

  1818. 

  1819.           DO J=JTS,min(JTE,JDE-1)
    1820. 

  1820.            TLM=WB-TDLM+MOD(J,2)*DLM
    1821. 

  1821.            TPH=SB+float(J-1)*DPH
    1822. 

  1822.            STPH=SIN(TPH)
    1823. 

  1823.            CTPH=COS(TPH)
    1824. 

  1824.            DO I=ITS,MIN(ITE,IDE-1)
    1825. 

  1825. 

  1826.         if (I .eq. ITS) THEN
    1827. 

  1827.              TLM=TLM+TDLM*ITS
    1828. 

  1828.         else
    1829. 

  1829.              TLM=TLM+TDLM
    1830. 

  1830.         endif
    1831. 

  1831. 

  1832.              FP=TWOM*(CTPH0*STPH+STPH0*CTPH*COS(TLM))
    1833. 

  1833. !jbao orig             grid%f(I,J)=0.5*GRID%DT*FP
    1834. 

  1834. ! jbao Coriolis correction for idealized!
    1835. 

  1835.              grid%f(I,J)=3.15656e-5*0.5*GRID%DT
    1836. 

  1836.              print*,'real 2griddt is ',grid%dt
    1837. 

  1837. ! jbao Coriolis correction for idealized!
    1838. 

  1838. 

  1839. 

  1840.            ENDDO
    1841. 

  1841.           ENDDO
    1842. 

  1842. 

  1843. ! --------------DERIVED VERTICAL GRID CONSTANTS--------------------------
    1844. 

  1844. 

  1845.       grid%ef4t=.5*GRID%DT/CP
    1846. 

  1846.       grid%f4q =   -GRID%DT*DTAD
    1847. 

  1847.       grid%f4d =-.5*GRID%DT*DTAD
    1848. 

  1848. 

  1849.        DO L=KDS,KDE-1
    1850. 

  1850.         grid%rdeta(L)=1./grid%deta(L)
    1851. 

  1851.         grid%f4q2(L)=-.25*GRID%DT*DTAD/grid%deta(L)
    1852. 

  1852.        ENDDO
    1853. 

  1853. 

  1854.         DO J=JTS,min(JTE,JDE-1)
    1855. 

  1855.         DO I=ITS,min(ITE,IDE-1)
    1856. 

  1856.           grid%dx_nmm(I,J)=DXJ(J)
    1857. 

  1857.           grid%wpdar(I,J)=WPDARJ(J)*grid%hbm2(I,J)
    1858. 

  1858.           grid%cpgfu(I,J)=CPGFUJ(J)*grid%vbm2(I,J)
    1859. 

  1859.           grid%curv(I,J)=CURVJ(J)*grid%vbm2(I,J)
    1860. 

  1860.           grid%fcp(I,J)=FCPJ(J)*grid%hbm2(I,J)
    1861. 

  1861.           grid%fdiv(I,J)=FDIVJ(J)*grid%hbm2(I,J)
    1862. 

  1862.           grid%fad(I,J)=FADJ(J)
    1863. 

  1863.           grid%hdacv(I,J)=HDACJ(J)*grid%vbm2(I,J)
    1864. 

  1864.           grid%hdac(I,J)=HDACJ(J)*1.25*grid%hbm2(I,J)
    1865. 

  1865.         ENDDO
    1866. 

  1866.         ENDDO
    1867. 

  1867. 

  1868.         DO J=JTS, MIN(JDE-1,JTE)
    1869. 

  1869. 

  1870.         IF (J.LE.5.OR.J.GE.(JDE-1)-4) THEN
    1871. 

  1871. 

  1872.                KHH=(IDE-1)-2+MOD(J,2) ! KHH is global...loop over I that have
    1873. 

  1873.                DO I=ITS,MIN(IDE-1,ITE)
    1874. 

  1874.                  IF (I .ge. 2 .and. I .le. KHH) THEN
    1875. 

  1875.                    grid%hdac(I,J)=grid%hdac(I,J)* DFC
    1876. 

  1876.                  ENDIF
    1877. 

  1877.                ENDDO
    1878. 

  1878. 

  1879.         ELSE
    1880. 

  1880. 

  1881.           KHH=2+MOD(J,2)
    1882. 

  1882.                DO I=ITS,MIN(IDE-1,ITE)
    1883. 

  1883.                  IF (I .ge. 2 .and. I .le. KHH) THEN
    1884. 

  1884.                     grid%hdac(I,J)=grid%hdac(I,J)* DFC
    1885. 

  1885.                  ENDIF
    1886. 

  1886.                ENDDO
    1887. 

  1887. 

  1888.           KHH=(IDE-1)-2+MOD(J,2)
    1889. 

  1889. 

  1890.                DO I=ITS,MIN(IDE-1,ITE)
    1891. 

  1891.                  IF (I .ge. (IDE-1)-2 .and. I .le. KHH) THEN
    1892. 

  1892.                    grid%hdac(I,J)=grid%hdac(I,J)* DFC
    1893. 

  1893.                  ENDIF
    1894. 

  1894.                ENDDO
    1895. 

  1895.         ENDIF
    1896. 

  1896.       ENDDO
    1897. 

  1897. 

  1898.       DO J=JTS,min(JTE,JDE-1)
    1899. 

  1899.       DO I=ITS,min(ITE,IDE-1)
    1900. 

  1900.         grid%ddmpu(I,J)=DDMPUJ(J)*grid%vbm2(I,J)
    1901. 

  1901.         grid%ddmpv(I,J)=DDMPVJ(J)*grid%vbm2(I,J)
    1902. 

  1902.         grid%hdacv(I,J)=grid%hdacv(I,J)*grid%vbm2(I,J)
    1903. 

  1903.       ENDDO
    1904. 

  1904.       ENDDO
    1905. 

  1905. ! --------------INCREASING DIFFUSION ALONG THE BOUNDARIES----------------
    1906. 

  1906. 

  1907.         DO J=JTS,MIN(JDE-1,JTE)
    1908. 

  1908.         IF (J.LE.5.OR.J.GE.JDE-1-4) THEN
    1909. 

  1909.           KVH=(IDE-1)-1-MOD(J,2)
    1910. 

  1910.           DO I=ITS,min(IDE-1,ITE)
    1911. 

  1911.             IF (I .ge. 2 .and.  I .le. KVH) THEN
    1912. 

  1912.              grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC
    1913. 

  1913.              grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC
    1914. 

  1914.              grid%hdacv(I,J)=grid%hdacv(I,J)* DFC
    1915. 

  1915.             ENDIF
    1916. 

  1916.           ENDDO
    1917. 

  1917.         ELSE
    1918. 

  1918.           KVH=3-MOD(J,2)
    1919. 

  1919.           DO I=ITS,min(IDE-1,ITE)
    1920. 

  1920.            IF (I .ge. 2 .and.  I .le. KVH) THEN
    1921. 

  1921.             grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC
    1922. 

  1922.             grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC
    1923. 

  1923.             grid%hdacv(I,J)=grid%hdacv(I,J)* DFC
    1924. 

  1924.            ENDIF
    1925. 

  1925.           ENDDO
    1926. 

  1926.           KVH=(IDE-1)-1-MOD(J,2)
    1927. 

  1927.           DO I=ITS,min(IDE-1,ITE)
    1928. 

  1928.            IF (I .ge. IDE-1-2 .and. I .le. KVH) THEN
    1929. 

  1929.             grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC
    1930. 

  1930.             grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC
    1931. 

  1931.             grid%hdacv(I,J)=grid%hdacv(I,J)* DFC
    1932. 

  1932.            ENDIF
    1933. 

  1933.           ENDDO
    1934. 

  1934.         ENDIF
    1935. 

  1935.       ENDDO
    1936. 

  1936. 

  1937.         write(message,*) 'grid%stc(1)'
    1938. 

  1938.         CALL wrf_message(message)
    1939. 

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

  1940.           write(message,635) (grid%stc(I,1,J),I=its,min(ite,ide-1),(ite-its)/12+1)
    1941. 

  1941.           CALL wrf_message(message)
    1942. 

  1942.         ENDDO
    1943. 

  1943. 

  1944.         write(message,*) 'grid%smc(1)'
    1945. 

  1945.         CALL wrf_message(message)
    1946. 

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

  1947.           write(message,635) (grid%smc(I,1,J),I=its,min(ite,ide-1),(ite-its)/12+1)
    1948. 

  1948.           CALL wrf_message(message)
    1949. 

  1949.         ENDDO
    1950. 

  1950. 

  1951.           DO j = jts, MIN(jde-1,jte)
    1952. 

  1952.           DO i=  ITS, MIN(IDE-1,ITE)
    1953. 

  1953. 

  1954.           if (grid%sm(I,J) .lt. 0.1 .and. grid%smc(I,1,J) .gt. 0.5 .and. grid%sice(I,J) .lt. 0.1) then
    1955. 

  1955.             write(message,*) 'very moist on land point: ', I,J,grid%smc(I,1,J)
    1956. 

  1956.             CALL wrf_debug(10,message)
    1957. 

  1957.           endif
    1958. 

  1958. 

  1959.           enddo
    1960. 

  1960.         enddo
    1961. 

  1961. 

  1962. !!!   compute grid%emt, grid%em on global domain, and only on task 0.
    1963. 

  1963. 

  1964. #ifdef DM_PARALLEL
    1965. 

  1965.         IF (wrf_dm_on_monitor()) THEN   !!!! NECESSARY TO LIMIT THIS TO TASK ZERO?
    1966. 

  1966. #else
    1967. 

  1967.         IF (JDS .eq. JTS) THEN !! set unfailable condition for serial job
    1968. 

  1968. #endif
    1969. 

  1969. 

  1970.         ALLOCATE(EMJ(JDS:JDE-1),EMTJ(JDS:JDE-1))
    1971. 

  1971. 

  1972.         DO J=JDS,JDE-1
    1973. 

  1973.          TPH=SB+float(J-1)*DPH
    1974. 

  1974.          DXP=ERAD*DLM*COS(TPH)
    1975. 

  1975.          EMJ(J)= GRID%DT/( 4.*DXP)*DTAD
    1976. 

  1976.          EMTJ(J)=GRID%DT/(16.*DXP)*DTAD
    1977. 

  1977.         ENDDO
    1978. 

  1978. 

  1979.           JA=0
    1980. 

  1980.           DO 161 J=3,5
    1981. 

  1981.           JA=JA+1
    1982. 

  1982.           KHLA(JA)=2
    1983. 

  1983.           KHHA(JA)=(IDE-1)-1-MOD(J+1,2)
    1984. 

  1984.  161      grid%emt(JA)=EMTJ(J)
    1985. 

  1985.           DO 162 J=(JDE-1)-4,(JDE-1)-2
    1986. 

  1986.           JA=JA+1
    1987. 

  1987.           KHLA(JA)=2
    1988. 

  1988.           KHHA(JA)=(IDE-1)-1-MOD(J+1,2)
    1989. 

  1989.  162      grid%emt(JA)=EMTJ(J)
    1990. 

  1990.           DO 163 J=6,(JDE-1)-5
    1991. 

  1991.           JA=JA+1
    1992. 

  1992.           KHLA(JA)=2
    1993. 

  1993.           KHHA(JA)=2+MOD(J,2)
    1994. 

  1994.  163      grid%emt(JA)=EMTJ(J)
    1995. 

  1995.           DO 164 J=6,(JDE-1)-5
    1996. 

  1996.           JA=JA+1
    1997. 

  1997.           KHLA(JA)=(IDE-1)-2
    1998. 

  1998.           KHHA(JA)=(IDE-1)-1-MOD(J+1,2)
    1999. 

  1999.  164      grid%emt(JA)=EMTJ(J)
    2000. 

  2000. 

  2001. ! --------------SPREADING OF UPSTREAM VELOCITY-POINT ADVECTION FACTOR----
    2002. 

  2002. 

  2003.       JA=0
    2004. 

  2004.               DO 171 J=3,5
    2005. 

  2005.           JA=JA+1
    2006. 

  2006.           KVLA(JA)=2
    2007. 

  2007.           KVHA(JA)=(IDE-1)-1-MOD(J,2)
    2008. 

  2008.  171      grid%em(JA)=EMJ(J)
    2009. 

  2009.               DO 172 J=(JDE-1)-4,(JDE-1)-2
    2010. 

  2010.           JA=JA+1
    2011. 

  2011.           KVLA(JA)=2
    2012. 

  2012.           KVHA(JA)=(IDE-1)-1-MOD(J,2)
    2013. 

  2013.  172      grid%em(JA)=EMJ(J)
    2014. 

  2014.               DO 173 J=6,(JDE-1)-5
    2015. 

  2015.           JA=JA+1
    2016. 

  2016.           KVLA(JA)=2
    2017. 

  2017.           KVHA(JA)=2+MOD(J+1,2)
    2018. 

  2018.  173      grid%em(JA)=EMJ(J)
    2019. 

  2019.               DO 174 J=6,(JDE-1)-5
    2020. 

  2020.           JA=JA+1
    2021. 

  2021.           KVLA(JA)=(IDE-1)-2
    2022. 

  2022.           KVHA(JA)=(IDE-1)-1-MOD(J,2)
    2023. 

  2023.  174      grid%em(JA)=EMJ(J)
    2024. 

  2024. 

  2025.    696  continue
    2026. 

  2026.         ENDIF ! wrf_dm_on_monitor/serial job
    2027. 

  2027. 

  2028.       call NMM_SH2O(IMS,IME,JMS,JME,ITS,NNXP,JTS,NNYP,grid%num_soil_layers,grid%isltyp, &
    2029. 

  2029.                              grid%sm,grid%sice,grid%stc,grid%smc,grid%sh2o)
    2030. 

  2030. 

  2031. !! must be a better place to put this, but will eliminate "phantom"
    2032. 

  2032. !! wind points here (no wind point on eastern boundary of odd numbered rows)
    2033. 

  2033. 

  2034.         IF (   abs(IDE-1-ITE) .eq. 1 ) THEN ! along eastern boundary
    2035. 

  2035.           write(message,*) 'zero phantom winds'
    2036. 

  2036.           CALL wrf_message(message)
    2037. 

  2037.           DO K=1,KDE-1
    2038. 

  2038.             DO J=JDS,JDE-1,2
    2039. 

  2039.               IF (J .ge. JTS .and. J .le. JTE) THEN
    2040. 

  2040.                 grid%u(IDE-1,J,K)=0.
    2041. 

  2041.                 grid%v(IDE-1,J,K)=0.
    2042. 

  2042.               ENDIF
    2043. 

  2043.             ENDDO
    2044. 

  2044.           ENDDO
    2045. 

  2045.         ENDIF
    2046. 

  2046. 

  2047.   969   continue
    2048. 

  2048. 

  2049.          DO j = jms, jme
    2050. 

  2050.             DO i = ims, ime
    2051. 

  2051.              fisx=max(grid%fis(i,j),0.)
    2052. 

  2052.              grid%z0(I,J)    =grid%sm(I,J)*Z0SEA+(1.-grid%sm(I,J))*                      &
    2053. 

  2053.      &                (0.*Z0MAX+FISx    *FCM+Z0LAND)
    2054. 

  2054.             ENDDO
    2055. 

  2055.           ENDDO
    2056. 

  2056. 

  2057.         write(message,*) 'grid%z0 over memory, leaving module_initialize_real'
    2058. 

  2058.         CALL wrf_message(message)
    2059. 

  2059.         DO J=JME,JMS,-((JME-JMS)/20+1)
    2060. 

  2060.           write(message,635) (grid%z0(I,J),I=IMS,IME,(IME-IMS)/14+1)
    2061. 

  2061.           CALL wrf_message(message)
    2062. 

  2062.         ENDDO
    2063. 

  2063. 

  2064. 

  2065.         endif ! on first_time check
    2066. 

  2066. 

  2067.         write(message,*) 'leaving init_domain_nmm'
    2068. 

  2068.         CALL wrf_message( TRIM(message) )
    2069. 

  2069. !
    2070. 

  2070.        write(message,*)'STUFF MOVED TO REGISTRY:',grid%IDTAD,          &
    2071. 

  2071.      & grid%NSOIL,grid%NRADL,grid%NRADS,grid%NPHS,grid%NCNVC,grid%sigma
    2072. 

  2072.        CALL wrf_message( TRIM(message) )
    2073. 

  2073. #ifdef HWRF
    2074. 

  2074. !=========================================================================================
    2075. 

  2075. !   gopal's doing for ocean coupling. Produce a high resolution grid for the entire domain
    2076. 

  2076. !=========================================================================================
    2077. 

  2077. 

  2078.     if(internal_time_loop.eq.1) then      !Kwon's doing
    2079. 

    2080. 

  2080.      NDLMD=grid%dlmd/3.
    2081. 

  2081.      NDPHD=grid%dphd/3.
    2082. 

  2082.      NIDE=3*(IDE-1)-2
    2083. 

  2083.      NJDE=3*(JDE-1)-2
    2084. 

  2084.      ILOC=1
    2085. 

  2085.      JLOC=1
    2086. 

  2086.      NWBD= WBD  ! + (ILOC -1)*2.*grid%dlmd + MOD(JLOC+1,2)*grid%dlmd
    2087. 

  2087.      NSBD= SBD  ! + (JLOC -1)*grid%dphd
    2088. 

  2088. 

  2089.      ALLOCATE (NHLAT(NIDE,NJDE))
    2090. 

  2090.      ALLOCATE (NHLON(NIDE,NJDE))
    2091. 

  2091.      ALLOCATE (NVLAT(NIDE,NJDE))
    2092. 

  2092.      ALLOCATE (NVLON(NIDE,NJDE))
    2093. 

  2093.      ALLOCATE (HRES_SM(NIDE,NJDE))
    2094. 

  2094. 

  2095. #if defined(DM_PARALLEL)
    2096. 

  2096.        if(wrf_dm_on_monitor()) then
    2097. 

  2097.           ! Only the monitor process does the actual work (kinda
    2098. 

  2098.           ! stupid; should be parallelized, but it's better than
    2099. 

  2099.           ! writing garbage like it did before with >1 process)
    2100. 

  2100. 

  2101.           ! Get high-res lat & lon:
    2102. 

  2102.      CALL EARTH_LATLON_hwrf (  NHLAT,NHLON,NVLAT,NVLON,  &    ! rotated lat,lon at H and V points
    2103. 

  2103.                           NDLMD,NDPHD,NWBD,NSBD,    &
    2104. 

  2104.                           tph0d,tlm0d,              &
    2105. 

  2105.                           1,NIDE,1,NJDE,1,1,        &
    2106. 

  2106.                           1,NIDE,1,NJDE,1,1,        &
    2107. 

  2107.                           1,NIDE,1,NJDE,1,1         )
    2108. 

  2108. 

  2109.           ! Interpolate landmask to high-res grid:
    2110. 

  2110.           CALL G2T2H_hwrf ( SM_G,HRES_SM,   & ! output grid index and weights
    2111. 

  2111.                   NHLAT,NHLON,                 & ! target (hres) input lat lon in degrees
    2112. 

  2112.                   grid%DLMD,grid%DPHD,WBD,SBD,           & ! parent res, west and south boundaries
    2113. 

  2113.                   tph0d,tlm0d,                 & ! parent central lat,lon, all in degrees
    2114. 

  2114.                IDE,JDE,IDS,IDE,JDS,JDE,     & ! parent imax and jmax, ime,jme
    2115. 

  2115.                   1,NIDE,1,NJDE,1,1,           &
    2116. 

  2116.                   1,NIDE,1,NJDE,1,1,           &
    2117. 

  2117.                   1,NIDE,1,NJDE,1,1            )
    2118. 

  2118. 

  2119.           ! We're done with the low-res sm grid now:
    2120. 

  2120.           deallocate(SM_G)
    2121. 

  2121. 

  2122.           ! Write out high-res grid for coupler:
    2123. 

  2123.          WRITE(65)NHLAT(1:NIDE,1:NJDE)
    2124. 

  2124.          WRITE(65)NHLON(1:NIDE,1:NJDE)
    2125. 

  2125.          WRITE(65)NVLAT(1:NIDE,1:NJDE)
    2126. 

  2126.          WRITE(65)NVLON(1:NIDE,1:NJDE)
    2127. 

  2127.          WRITE(65)HRES_SM(1:NIDE,1:NJDE)
    2128. 

  2128.       endif
    2129. 

  2129. #else
    2130. 

  2130.        ! This code is the same as above, but for the non-mpi version:
    2131. 

  2131.        CALL EARTH_LATLON_hwrf (  NHLAT,NHLON,NVLAT,NVLON,  &    ! rotated lat,lon at H and V points
    2132. 

  2132.             NDLMD,NDPHD,NWBD,NSBD,    &
    2133. 

  2133.             tph0d,tlm0d,              &
    2134. 

  2134.             1,NIDE,1,NJDE,1,1,        &
    2135. 

  2135.             1,NIDE,1,NJDE,1,1,        &
    2136. 

  2136.             1,NIDE,1,NJDE,1,1         )
    2137. 

  2137.        CALL G2T2H_hwrf ( grid%SM,HRES_SM,                  & ! output grid index and weights
    2138. 

  2138.             NHLAT,NHLON,                 & ! target (hres) input lat lon in degrees
    2139. 

  2139.             grid%DLMD,grid%DPHD,WBD,SBD,           & ! parent res, west and south boundaries
    2140. 

  2140.             tph0d,tlm0d,                 & ! parent central lat,lon, all in degrees
    2141. 

  2141.             IDE,JDE,IMS,IME,JMS,JME,     & ! parent imax and jmax, ime,jme
    2142. 

  2142.             1,NIDE,1,NJDE,1,1,           &
    2143. 

  2143.             1,NIDE,1,NJDE,1,1,           &
    2144. 

  2144.             1,NIDE,1,NJDE,1,1            )
    2145. 

  2145. 

  2146.          WRITE(65)NHLAT(1:NIDE,1:NJDE)
    2147. 

  2147.          WRITE(65)NHLON(1:NIDE,1:NJDE)
    2148. 

  2148.          WRITE(65)NVLAT(1:NIDE,1:NJDE)
    2149. 

  2149.          WRITE(65)NVLON(1:NIDE,1:NJDE)
    2150. 

  2150.          WRITE(65)HRES_SM(1:NIDE,1:NJDE)
    2151. 

  2151. #endif
    2152. 

  2152. 

  2153.      DEALLOCATE (NHLAT)
    2154. 

  2154.      DEALLOCATE (NHLON)
    2155. 

  2155.      DEALLOCATE (NVLAT)
    2156. 

  2156.      DEALLOCATE (NVLON)
    2157. 

  2157.      DEALLOCATE (HRES_SM)
    2158. 

  2158. 

  2159.      endif                 !Kwon's doing
    2160. 

    2161. 

  2161. !==================================================================================
    2162. 

  2162. !   end gopal's doing for ocean coupling.
    2163. 

  2163. !==================================================================================
    2164. 

  2164. #endif
    2165. 

  2165. 

  2166. !#define COPY_OUT
    2167. 

  2167. !#include <scalar_derefs.inc>
    2168. 

  2168.       RETURN
    2169. 

  2169. 

  2170.    END SUBROUTINE init_domain_nmm
    2171. 

  2171. 

  2172. !------------------------------------------------------
    2173. 

  2173. 

  2174.   SUBROUTINE define_nmm_vertical_coord ( LM, PTSGM, pt, pdtop,HYBLEVS, &
    2175. 

  2175.                                          SG1,DSG1,SGML1,         &
    2176. 

  2176.                                          SG2,DSG2,SGML2,dfl, dfrlg            )
    2177. 

  2177. 

  2178.         IMPLICIT NONE
    2179. 

  2179. 

  2180. !        USE module_model_constants
    2181. 

  2181. 

  2182. !!! certain physical parameters here probably don't need to be defined, as defined
    2183. 

  2183. !!! elsewhere within WRF.  Done for initial testing purposes.
    2184. 

  2184. 

  2185.         INTEGER ::  LM, LPT2, L
    2186. 

  2186.         REAL    ::  PTSGM, pt, PL, PT2, pdtop
    2187. 

  2187.         REAL    ::  RGOG, PSIG,PHYB,PHYBM
    2188. 

  2188.         REAL, PARAMETER  :: Rd           =  287.04  ! J deg{-1} kg{-1}
    2189. 

  2189.         REAL, PARAMETER :: CP=1004.6,GAMMA=.0065,PRF0=101325.,T0=288.
    2190. 

  2190.         REAL, PARAMETER :: g=9.81
    2191. 

  2191. 

  2192.         REAL, DIMENSION(LM)   :: DSG,DSG1,DSG2
    2193. 

  2193.         REAL, DIMENSION(LM)   :: SGML1,SGML2
    2194. 

  2194.         REAL, DIMENSION(LM+1) :: SG1,SG2,HYBLEVS,dfl,dfrlg
    2195. 

  2195. 

  2196.         CHARACTER(LEN=255)    :: message
    2197. 

  2197. 

  2198.         LPT2=LM+1
    2199. 

  2199. 

  2200.         write(message,*) 'pt= ', pt
    2201. 

  2201.         CALL wrf_message(message)
    2202. 

  2202. 

  2203.         DO L=LM+1,1,-1
    2204. 

  2204.           pl=HYBLEVS(L)*(101325.-pt)+pt
    2205. 

  2205.           if(pl.lt.ptSGm) LPT2=l
    2206. 

  2206.         ENDDO
    2207. 

  2207. 

  2208.       IF(LPT2.lt.LM+1) THEN
    2209. 

  2209.         pt2=HYBLEVS(LPT2)*(101325.-pt)+pt
    2210. 

  2210.       ELSE
    2211. 

  2211.         pt2=pt
    2212. 

  2212.       ENDIF
    2213. 

  2213. 

  2214.       write(message,*) '*** Sigma system starts at ',pt2,' Pa, from level ',LPT2
    2215. 

  2215.       CALL wrf_message(message)
    2216. 

  2216. 

  2217.       pdtop=pt2-pt
    2218. 

  2218. 

  2219.         write(message,*) 'allocating DSG,DSG1,DSG2 as ', LM
    2220. 

  2220.         CALL wrf_debug(10,message)
    2221. 

  2221. 

  2222.         DSG=-99.
    2223. 

  2223. 

  2224.       DO L=1,LM
    2225. 

  2225.         DSG(L)=HYBLEVS(L)- HYBLEVS(L+1)
    2226. 

  2226.       ENDDO
    2227. 

  2227. 

  2228.         DSG1=0.
    2229. 

  2229.         DSG2=0.
    2230. 

  2230. 

  2231.       DO L=LM,1,-1
    2232. 

  2232. 

  2233.        IF(L.ge.LPT2) then
    2234. 

  2234.         DSG1(L)=DSG(L)
    2235. 

  2235.        ELSE
    2236. 

  2236.         DSG2(L)=DSG(L)
    2237. 

  2237.        ENDIF
    2238. 

  2238. 

  2239.       ENDDO
    2240. 

  2240. 

  2241.         SGML1=-99.
    2242. 

  2242.         SGML2=-99.
    2243. 

  2243. 

  2244.        IF(LPT2.le.LM+1) THEN
    2245. 

  2245. 

  2246.         DO L=LM+1,LPT2,-1
    2247. 

  2247.         SG2(L)=0.
    2248. 

  2248.         ENDDO
    2249. 

  2249. 

  2250.        DO L=LPT2,2,-1
    2251. 

  2251.         SG2(L-1)=SG2(L)+DSG2(L-1)
    2252. 

  2252.        ENDDO
    2253. 

  2253. 

  2254.         DO L=LPT2-1,1,-1
    2255. 

  2255.         SG2(L)=SG2(L)/SG2(1)
    2256. 

  2256.         ENDDO
    2257. 

  2257.         SG2(1)=1.
    2258. 

  2258. 

  2259.        DO L=LPT2-1,1,-1
    2260. 

  2260.         DSG2(L)=SG2(L)-SG2(L+1)
    2261. 

  2261.         SGML2(l)=(SG2(l)+SG2(l+1))*0.5
    2262. 

  2262.        ENDDO
    2263. 

  2263. 

  2264.       ENDIF
    2265. 

  2265. 

  2266.       DO L=LM,LPT2,-1
    2267. 

  2267.         DSG2(L)=0.
    2268. 

  2268.         SGML2(L)=0.
    2269. 

  2269.       ENDDO
    2270. 

  2270. 

  2271. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    2272. 

  2272. 

  2273.         SG1(LM+1)=0.
    2274. 

  2274. 

  2275.       DO L=LM+1,LPT2,-1
    2276. 

  2276.        SG1(L-1)=SG1(L)+DSG1(L-1)
    2277. 

  2277.       ENDDO
    2278. 

  2278. 

  2279.       DO L=LM,LPT2,-1
    2280. 

  2280.        SG1(L)=SG1(L)/SG1(LPT2-1)
    2281. 

  2281.       ENDDO
    2282. 

  2282. 

  2283.         SG1(LPT2-1)=1.
    2284. 

  2284. 

  2285.        do l=LPT2-2,1,-1
    2286. 

  2286.         SG1(l)=1.
    2287. 

  2287.        enddo
    2288. 

  2288. 

  2289. 

  2290.       DO L=LM,LPT2,-1
    2291. 

  2291.        DSG1(L)=SG1(L)-SG1(L+1)
    2292. 

  2292.        SGML1(L)=(SG1(L)+SG1(L+1))*0.5
    2293. 

  2293.       ENDDO
    2294. 

  2294. 

  2295.       DO L=LPT2-1,1,-1
    2296. 

  2296.                DSG1(L)=0.
    2297. 

  2297.                SGML1(L)=1.
    2298. 

  2298.       ENDDO
    2299. 

  2299. 

  2300.  1000 format('l,hyblevs,psig,SG1,SG2,phyb,phybm')
    2301. 

  2301.  1100 format(' ',i4,f7.4,f10.2,2f7.4,2f10.2)
    2302. 

  2302. 

  2303.       write(message,1000)
    2304. 

  2304.       CALL wrf_debug(100,message)
    2305. 

  2305. 

  2306.       do l=1,LM+1
    2307. 

  2307.         psig=HYBLEVS(L)*(101325.-pt)+pt
    2308. 

  2308.         phyb=SG1(l)*pdtop+SG2(l)*(101325.-pdtop-pt)+pt
    2309. 

  2309.         if(l.lt.LM+1) then
    2310. 

  2310.           phybm=SGML1(l)*pdtop+SGML2(l)*(101325.-pdtop-pt)+pt
    2311. 

  2311.         else
    2312. 

  2312.           phybm=-99.
    2313. 

  2313.         endif
    2314. 

  2314. 

  2315.         write(message,1100) l,HYBLEVS(L),psig &
    2316. 

  2316.                       ,SG1(l),SG2(l),phyb,phybm
    2317. 

  2317.         CALL wrf_debug(100,message)
    2318. 

  2318.       enddo
    2319. 

  2319. 

  2320. 

  2321.   632   format(f9.6)
    2322. 

  2322. 

  2323.        write(message,*) 'SG1'
    2324. 

  2324.        CALL wrf_debug(100,message)
    2325. 

  2325.        do L=LM+1,1,-1
    2326. 

  2326.        write(message,632) SG1(L)
    2327. 

  2327.        CALL wrf_debug(100,message)
    2328. 

  2328.        enddo
    2329. 

  2329. 

  2330.        write(message,*) 'SG2'
    2331. 

  2331.        CALL wrf_debug(100,message)
    2332. 

  2332.        do L=LM+1,1,-1
    2333. 

  2333.        write(message,632) SG2(L)
    2334. 

  2334.        CALL wrf_debug(100,message)
    2335. 

  2335.        enddo
    2336. 

  2336. 

  2337.        write(message,*) 'DSG1'
    2338. 

  2338.        CALL wrf_debug(100,message)
    2339. 

  2339.        do L=LM,1,-1
    2340. 

  2340.        write(message,632) DSG1(L)
    2341. 

  2341.        CALL wrf_debug(100,message)
    2342. 

  2342.        enddo
    2343. 

  2343. 

  2344.        write(message,*) 'DSG2'
    2345. 

  2345.        CALL wrf_debug(100,message)
    2346. 

  2346.        do L=LM,1,-1
    2347. 

  2347.        write(message,632) DSG2(L)
    2348. 

  2348.        CALL wrf_debug(100,message)
    2349. 

  2349.        enddo
    2350. 

  2350. 

  2351.        write(message,*) 'SGML1'
    2352. 

  2352.        CALL wrf_debug(100,message)
    2353. 

  2353.        do L=LM,1,-1
    2354. 

  2354.        write(message,632) SGML1(L)
    2355. 

  2355.        CALL wrf_debug(100,message)
    2356. 

  2356.        enddo
    2357. 

  2357. 

  2358.        write(message,*) 'SGML2'
    2359. 

  2359.        CALL wrf_debug(100,message)
    2360. 

  2360.        do L=LM,1,-1
    2361. 

  2361.        write(message,632) SGML2(L)
    2362. 

  2362.        CALL wrf_debug(100,message)
    2363. 

  2363.        enddo
    2364. 

  2364. 

  2365.       rgog=(rd*gamma)/g
    2366. 

  2366.       DO L=1,LM+1
    2367. 

  2367.         dfl(L)=g*T0*(1.-((pt+SG1(L)*pdtop+SG2(L)*(101325.-pt2)) &
    2368. 

  2368.                        /101325.)**rgog)/gamma
    2369. 

  2369.         dfrlg(L)=dfl(L)/g
    2370. 

  2370.        write(message,*) 'L, dfl(L): ', L, dfl(L)
    2371. 

  2371.        CALL wrf_debug(100,message)
    2372. 

  2372.       ENDDO
    2373. 

  2373. 

  2374.   END SUBROUTINE define_nmm_vertical_coord
    2375. 

  2375. 

  2376. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    2377. 

  2377. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    2378. 

  2378. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    2379. 

  2379. 

  2380.   SUBROUTINE compute_nmm_surfacep ( TERRAIN_HGT_T, Z3D_IN, PRESS3D_IN, T3D_IN   &
    2381. 

  2381.      &,                             psfc_out,generic           &
    2382. 

  2382.      &,                             IDS,IDE,JDS,JDE,KDS,KDE             &
    2383. 

  2383.      &,                             IMS,IME,JMS,JME,KMS,KME             &
    2384. 

  2384.      &,                             ITS,ITE,JTS,JTE,KTS,KTE  )
    2385. 

  2385. 

  2386. 	
    2387. 

  2387.        IMPLICIT NONE
    2388. 

  2388. 

  2389.        real, allocatable:: dum2d(:,:),DUM2DB(:,:)
    2390. 

  2390. 

  2391.        integer :: IDS,IDE,JDS,JDE,KDS,KDE
    2392. 

  2392.        integer :: IMS,IME,JMS,JME,KMS,KME
    2393. 

  2393.        integer :: ITS,ITE,JTS,JTE,KTS,KTE,Ilook,Jlook
    2394. 

  2394.        integer :: I,J,II,generic,L,KINSERT,K,bot_lev,LL
    2395. 

  2395.        integer :: IHE(JMS:JME),IHW(JMS:JME)
    2396. 

  2396. 

  2397.        real :: TERRAIN_HGT_T(IMS:IME,JMS:JME)
    2398. 

  2398.        real :: Z3D_IN(IMS:IME,JMS:JME,generic)
    2399. 

  2399.        real :: T3D_IN(IMS:IME,JMS:JME,generic)
    2400. 

  2400.        real :: PRESS3D_IN(IMS:IME,JMS:JME,generic)
    2401. 

  2401.        real :: PSFC_IN(IMS:IME,JMS:JME),TOPO_IN(IMS:IME,JMS:JME)
    2402. 

  2402.        real :: psfc_out(IMS:IME,JMS:JME),rincr(IMS:IME,JMS:JME)
    2403. 

  2403.        real :: dif1,dif2,dif3,dif4,dlnpdz,BOT_INPUT_HGT,BOT_INPUT_PRESS,dpdz,rhs
    2404. 

  2404.        real :: zin(generic),pin(generic)
    2405. 

  2405. 

  2406.        character (len=255) :: message
    2407. 

  2407. 	
    2408. 

  2408.        logical :: DEFINED_PSFC(IMS:IME,JMS:JME), DEFINED_PSFCB(IMS:IME,JMS:JME)
    2409. 

  2409. 

  2410. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    2411. 

  2411. 

  2412. 	Ilook=25
    2413. 

  2413.         Jlook=25
    2414. 

  2414. 

  2415.        DO j = JMS, JME
    2416. 

  2416.           IHE(J)=MOD(J+1,2)
    2417. 

  2417.           IHW(J)=IHE(J)-1
    2418. 

  2418.        ENDDO
    2419. 

  2419. 

  2420.        DO J=JMS,JME
    2421. 

  2421.        DO I=IMS,IME
    2422. 

  2422.           DEFINED_PSFC(I,J)=.FALSE.
    2423. 

  2423.           DEFINED_PSFCB(I,J)=.FALSE.
    2424. 

  2424.         IF (PRESS3D_IN(I,J,1) .ne. 200100.) THEN
    2425. 

  2425.           PSFC_IN(I,J)=PRESS3D_IN(I,J,1)
    2426. 

  2426.           TOPO_IN(I,J)=Z3D_IN(I,J,1)
    2427. 

  2427.         ELSE
    2428. 

  2428.           PSFC_IN(I,J)=PRESS3D_IN(I,J,2)
    2429. 

  2429.           TOPO_IN(I,J)=Z3D_IN(I,J,2)
    2430. 

  2430.         ENDIF
    2431. 

  2431.        ENDDO
    2432. 

  2432.        ENDDO
    2433. 

  2433. 

  2434. ! input surface pressure smoothing over the ocean - still needed for NAM?
    2435. 

  2435. 

  2436.         II_loop: do II=1,8
    2437. 

  2437. 

  2438.         CYCLE II_loop
    2439. 

  2439. 

  2440. 	do J=JTS+1,min(JTE,JDE-1)-1
    2441. 

  2441.          do I=ITS+1,min(ITE,IDE-1)-1
    2442. 

  2442.          rincr(I,J)=0.
    2443. 

  2443. 

  2444.        if (PSFC_IN(I,J) .gt. 100000.          .and. &
    2445. 

  2445.            PSFC_IN(I+IHE(J),J+1) .gt. 100000. .and. &
    2446. 

  2446.            PSFC_IN(I+IHE(J),J-1) .gt. 100000. .and. &
    2447. 

  2447.            PSFC_IN(I+IHW(J),J+1) .gt. 100000. .and. &
    2448. 

  2448.            PSFC_IN(I+IHW(J),J-1) .gt. 100000. ) then
    2449. 

  2449. 

  2450.        dif1=abs(PSFC_IN(I,J)-PSFC_IN(I+IHE(J),J+1))
    2451. 

  2451.        dif2=abs(PSFC_IN(I,J)-PSFC_IN(I+IHE(J),J-1))
    2452. 

  2452.        dif3=abs(PSFC_IN(I,J)-PSFC_IN(I+IHW(J),J+1))
    2453. 

  2453.        dif4=abs(PSFC_IN(I,J)-PSFC_IN(I+IHW(J),J-1))
    2454. 

  2454. 

  2455.         if (max(dif1,dif2,dif3,dif4) .lt. 200. .and. TOPO_IN(I,J).le. 0.5 .and. &
    2456. 

  2456.             TOPO_IN(I+IHE(J),J+1) .le. 0.5 .and. &
    2457. 

  2457.             TOPO_IN(I+IHW(J),J+1) .le. 0.5 .and. &
    2458. 

  2458.             TOPO_IN(I+IHE(J),J-1) .le. 0.5 .and. &
    2459. 

  2459.             TOPO_IN(I+IHW(J),J-1) .lt. 0.5) then
    2460. 

  2460. 

  2461.         rincr(I,J)=0.125*( 4.*PSFC_IN(I,J)+ &
    2462. 

  2462.                             PSFC_IN(I+IHE(J),J+1)+PSFC_IN(I+IHE(J),J-1)+ &
    2463. 

  2463.                             PSFC_IN(I+IHW(J),J+1)+PSFC_IN(I+IHW(J),J-1) ) &
    2464. 

  2464.                           - PSFC_IN(I,J)
    2465. 

  2465. 

  2466. !        if (rincr(I,J) .ne. 0 .and. abs(rincr(I,J)) .gt. 20.) then
    2467. 

  2467. !          write(message,*) 'II, I,J,rincr: ', II, I,J,rincr(I,J)
    2468. 

  2468. !          CALL wrf_message(message)
    2469. 

  2469. !        endif
    2470. 

  2470. 

  2471.          endif
    2472. 

  2472.          endif
    2473. 

  2473. 

  2474.         ENDDO
    2475. 

  2475.         ENDDO
    2476. 

  2476. 

  2477.        DO J=JTS+1,min(JTE,JDE-1)-1
    2478. 

  2478.          DO I=ITS+1,min(ITE,IDE-1)-1
    2479. 

  2479.            PSFC_IN(I,J)=PSFC_IN(I,J) + rincr(I,J)
    2480. 

  2480.          ENDDO
    2481. 

  2481.        ENDDO
    2482. 

  2482. 

  2483. !        write(message,*) ' -------------------------------------------------- '
    2484. 

  2484. !        CALL wrf_message(message)
    2485. 

  2485. 

  2486.          end do II_loop
    2487. 

  2487. 

  2488.        ALLOCATE(DUM2D(IMS:IME,JMS:JME))
    2489. 

  2489. 

  2490.        DO J=JMS,JME
    2491. 

  2491.         DO I=IMS,IME
    2492. 

  2492.          DUM2D(I,J)=-9.
    2493. 

  2493.         END DO
    2494. 

  2494.        END DO
    2495. 

  2495. 

  2496.        DO J=JTS,min(JTE,JDE-1)
    2497. 

  2497.         I_loop: DO I=ITS,min(ITE,IDE-1)
    2498. 

  2498. 

  2499.          IF (PSFC_IN(I,J) .lt. 0.1) THEN
    2500. 

  2500.            write(message,*) 'QUITTING BECAUSE I,J, PSFC_IN: ', I,J,PSFC_IN(I,J)
    2501. 

  2501.            call wrf_error_fatal(message)
    2502. 

  2502.          ENDIF
    2503. 

  2503. 

  2504.          BOT_INPUT_PRESS=PSFC_IN(I,J)
    2505. 

  2505.          BOT_INPUT_HGT=TOPO_IN(I,J)
    2506. 

  2506. 

  2507.          IF (I .eq. Ilook .AND. J .eq. Jlook) THEN
    2508. 

  2508. 

  2509. 	   write(message,*) ' TERRAIN_HGT_T: ', I,J, TERRAIN_HGT_T(I,J)
    2510. 

  2510.            CALL wrf_message(message)
    2511. 

  2511. 	   write(message,*) ' PSFC_IN, TOPO_IN: ', &
    2512. 

  2512.                             I, J, PSFC_IN(I,J),TOPO_IN(I,J)
    2513. 

  2513.            CALL wrf_message(message)
    2514. 

  2514. 

  2515.            DO L=1,generic
    2516. 

  2516. 	     write(message,*) ' L,PRESS3D_IN, Z3D_IN: ', &
    2517. 

  2517.                              I,J,L, PRESS3D_IN(I,J,L),Z3D_IN(I,J,L)
    2518. 

  2518.              CALL wrf_debug(10,message)
    2519. 

  2519.            END DO
    2520. 

  2520.          ENDIF
    2521. 

  2521. 

  2522.        DO L=2,generic-1
    2523. 

  2523. 

  2524.          IF ( PRESS3D_IN(i,j,L) .gt. PSFC_IN(I,J) .AND.  &
    2525. 

  2525.              Z3D_IN(I,J,L) .lt. TERRAIN_HGT_T(I,J) .AND. &
    2526. 

  2526.              Z3D_IN(I,J,L+1) .gt. TERRAIN_HGT_T(I,J) ) THEN
    2527. 

  2527. 

  2528.            BOT_INPUT_PRESS=PRESS3D_IN(i,j,L)
    2529. 

  2529.            BOT_INPUT_HGT=Z3D_IN(I,J,L)
    2530. 

  2530. 

  2531. !           IF (I .eq. Ilook .and. J .eq. Jlook) THEN
    2532. 

  2532. !             write(message,*) 'BOT_INPUT_PRESS, BOT_INPUT_HGT NOW : ', &
    2533. 

  2533. !                         Ilook,Jlook, BOT_INPUT_PRESS, BOT_INPUT_HGT
    2534. 

  2534. !             CALL wrf_message(message)
    2535. 

  2535. !           ENDIF
    2536. 

  2536. 

  2537.           ENDIF
    2538. 

  2538.        END DO	
    2539. 

  2539. 

  2540. !!!!!!!!!!!!!!!!!!!!!! START HYDRO CHECK
    2541. 

  2541. 

  2542.        IF ( PRESS3D_IN(i,j,1) .ne. 200100. .AND. &
    2543. 

  2543.           (PSFC_IN(I,J) .gt. PRESS3D_IN(i,j,2) .OR. &
    2544. 

  2544.            TOPO_IN(I,J) .lt. Z3D_IN(I,J,2)) ) THEN        ! extrapolate downward
    2545. 

  2545. 

  2546.          IF (J .eq. JTS .AND. I .eq. ITS) THEN
    2547. 

  2547.             write(message,*) 'hydro check - should only be for isobaric input'
    2548. 

  2548.             CALL wrf_message(message)
    2549. 

  2549.          ENDIF
    2550. 

  2550. 

  2551. 	 IF (Z3D_IN(I,J,2) .ne. TOPO_IN(I,J)) THEN
    2552. 

  2552.            dpdz=(PRESS3D_IN(i,j,2)-PSFC_IN(I,J))/(Z3D_IN(I,J,2)-TOPO_IN(I,J))
    2553. 

  2553.            rhs=-9.81*((PRESS3D_IN(i,j,2)+ PSFC_IN(I,J))/2.)/(287.04* T3D_IN(I,J,2))
    2554. 

  2554. 

  2555. 	   IF ( abs(PRESS3D_IN(i,j,2)-PSFC_IN(I,J)) .gt. 290.) THEN
    2556. 

  2556.              IF (dpdz .lt. 1.05*rhs .OR. dpdz .gt. 0.95*rhs) THEN
    2557. 

  2557.                 write(message,*) 'I,J,P(2),Psfc,Z(2),Zsfc: ', &
    2558. 

  2558.                     I,J,PRESS3D_IN(i,j,2),PSFC_IN(I,J),Z3D_IN(I,J,2),TOPO_IN(I,J)
    2559. 

  2559.                IF (mod(I,5).eq.0 .AND. mod(J,5).eq.0) CALL wrf_debug(50,message)
    2560. 

  2560. 	      CYCLE I_loop
    2561. 

  2561.              ENDIF
    2562. 

  2562. 

  2563.            ENDIF
    2564. 

  2564. 

  2565.          ELSE ! z(2) equals TOPO_IN
    2566. 

  2566. 

  2567. 	  IF (PRESS3D_IN(i,j,2) .eq. PSFC_IN(I,J)) THEN
    2568. 

  2568. !	    write(message,*) 'all equal at I,J: ', I,J
    2569. 

  2569. !           CALL wrf_message(message)
    2570. 

  2570.           ELSE
    2571. 

  2571. !           write(message,*) 'heights equal, pressures not: ', &
    2572. 

  2572. !                           PRESS3D_IN(i,j,2), PSFC_IN(I,J)
    2573. 

  2573. !           CALL wrf_message(message)
    2574. 

  2574. 	    CYCLE I_loop
    2575. 

  2575. 	  ENDIF
    2576. 

  2576. 

  2577.          ENDIF
    2578. 

  2578. 

  2579.          IF ( abs(PRESS3D_IN(i,j,2)-PSFC_IN(I,J)) .gt. 290.) THEN
    2580. 

  2580.            IF (PRESS3D_IN(i,j,2) .lt. PSFC_IN(I,J) .and. &
    2581. 

  2581.                           Z3D_IN(I,J,2) .lt. TOPO_IN(I,J)) THEN
    2582. 

  2582. !            write(message,*) 'surface data mismatch(a) at I,J: ', I,J
    2583. 

  2583. !            CALL wrf_message(message)
    2584. 

  2584. 	     CYCLE I_loop
    2585. 

  2585.            ELSEIF (PRESS3D_IN(i,j,2) .gt. PSFC_IN(I,J) .AND.  &
    2586. 

  2586.                   Z3D_IN(I,J,2) .gt. TOPO_IN(I,J)) THEN
    2587. 

  2587. !             write(message,*) 'surface data mismatch(b) at I,J: ', I,J
    2588. 

  2588. !             CALL wrf_message(message)
    2589. 

  2589.              CYCLE I_loop
    2590. 

  2590.            ENDIF
    2591. 

  2591.          ENDIF
    2592. 

  2592.        ENDIF
    2593. 

  2593. 

  2594. !!!!!!! loop over a few more levels
    2595. 

  2595. 

  2596.         DO L=3,6
    2597. 

  2597.           IF ( PRESS3D_IN(i,j,1) .ne. 200100. .AND. &
    2598. 

  2598.              (((PSFC_IN(I,J)-PRESS3D_IN(i,j,L)) .lt. 400.) .OR. &
    2599. 

  2599.                TOPO_IN(I,J) .lt. Z3D_IN(I,J,L))) then
    2600. 

  2600. 

  2601. 	    IF (Z3D_IN(I,J,L) .ne. TOPO_IN(I,J)) THEN
    2602. 

  2602.               dpdz=(PRESS3D_IN(i,j,L)-PSFC_IN(I,J))/ &
    2603. 

  2603.                    (Z3D_IN(I,J,L)-TOPO_IN(I,J))
    2604. 

  2604.               rhs=-9.81*((PRESS3D_IN(i,j,L)+ PSFC_IN(I,J))/2.)/ &
    2605. 

  2605.                         (287.04*T3D_IN(I,J,L))
    2606. 

  2606.               IF ( abs(PRESS3D_IN(i,j,L)-PSFC_IN(I,J)) .gt. 290.) THEN
    2607. 

  2607.                 IF (dpdz .lt. 1.05*rhs .or. dpdz .gt. 0.95*rhs) THEN
    2608. 

  2608.                   write(message,*) 'I,J,L,Piso,Psfc,Ziso,Zsfc: ', &
    2609. 

  2609.                                     I,J,L,PRESS3D_IN(i,j,L),PSFC_IN(I,J),&
    2610. 

  2610.                                     Z3D_IN(I,J,L),TOPO_IN(I,J)
    2611. 

  2611.                   IF (mod(I,5).eq.0 .AND. mod(J,5).eq.0) &
    2612. 

  2612.                                                CALL wrf_debug(50,message)
    2613. 

  2613. 	          CYCLE I_loop
    2614. 

  2614.                 ENDIF
    2615. 

  2615.               ENDIF
    2616. 

  2616.             ELSE
    2617. 

  2617. 	      IF (PRESS3D_IN(i,j,2) .eq. PSFC_IN(I,J)) THEN
    2618. 

  2618. !	        write(message,*) 'all equal at I,J: ', I,J
    2619. 

  2619. !               CALL wrf_message(message)
    2620. 

  2620.               ELSE
    2621. 

  2621. 	        CYCLE I_loop
    2622. 

  2622.               ENDIF
    2623. 

  2623.             ENDIF
    2624. 

  2624.           ENDIF
    2625. 

  2625. 

  2626. 	  IF ( abs(PRESS3D_IN(i,j,L)-PSFC_IN(I,J)) .gt. 290.) THEN
    2627. 

  2627.             IF (PRESS3D_IN(i,j,L) .lt. PSFC_IN(I,J) .AND. &
    2628. 

  2628.                     Z3D_IN(I,J,L) .lt. TOPO_IN(I,J)) THEN
    2629. 

  2629.               CYCLE I_loop
    2630. 

  2630.             ELSEIF (PRESS3D_IN(i,j,L) .gt. PSFC_IN(I,J) .AND.  &
    2631. 

  2631.                     Z3D_IN(I,J,L) .gt. TOPO_IN(I,J)) THEN
    2632. 

  2632.              CYCLE I_loop
    2633. 

  2633.             ENDIF
    2634. 

  2634.           ENDIF
    2635. 

  2635.         END DO
    2636. 

  2636. !!!!!!!!!!!!!!!!!!!!!! END HYDRO CHECK
    2637. 

  2637. 

  2638.         IF (TERRAIN_HGT_T(I,J) .eq. BOT_INPUT_HGT ) THEN
    2639. 

  2639.            dum2d(I,J)=BOT_INPUT_PRESS
    2640. 

  2640. 

  2641. 	  IF (BOT_INPUT_HGT .ne. 0. .and. (BOT_INPUT_HGT-INT(BOT_INPUT_HGT) .ne. 0.) ) THEN
    2642. 

  2642. 	    write(message,*) 'with BOT_INPUT_HGT: ', BOT_INPUT_HGT, &
    2643. 

  2643.                              'set dum2d to bot_input_pres: ', I,J,dum2d(I,J)
    2644. 

  2644.             CALL wrf_message(message)
    2645. 

  2645.           ENDIF
    2646. 

  2646. 

  2647.           IF (dum2d(I,J) .lt. 50000. .OR. dum2d(I,J) .gt. 109000.) THEN
    2648. 

  2648.             write(message,*) 'bad dum2d(a): ', I,J,DUM2D(I,J)
    2649. 

  2649.             CALL wrf_message(message)
    2650. 

  2650.           ENDIF
    2651. 

  2651. 

  2652.         ELSEIF (TERRAIN_HGT_T(I,J) .lt. BOT_INPUT_HGT ) THEN
    2653. 

  2653. 

  2654. !         target is below lowest possible input...extrapolate
    2655. 

  2655. 

  2656.           IF ( BOT_INPUT_PRESS-PRESS3D_IN(I,J,2) .gt. 500. ) THEN
    2657. 

  2657.             dlnpdz= (log(BOT_INPUT_PRESS)-log(PRESS3D_IN(i,j,2)) ) / &
    2658. 

  2658.                      (BOT_INPUT_HGT-Z3D_IN(i,j,2))
    2659. 

  2659.             IF (I .eq. Ilook .and. J .eq. Jlook) THEN
    2660. 

  2660.               write(message,*) 'I,J,dlnpdz(a): ', I,J,dlnpdz
    2661. 

  2661.               CALL wrf_message(message)
    2662. 

  2662.             ENDIF
    2663. 

  2663. 

  2664.           ELSE
    2665. 

  2665. 

  2666. !! thin layer and/or just have lowest level - difference with 3rd level data
    2667. 

  2667.             IF ( abs(BOT_INPUT_PRESS - PRESS3D_IN(i,j,3)) .gt. 290. ) THEN
    2668. 

  2668. 

  2669.               dlnpdz= (log(BOT_INPUT_PRESS)-log(PRESS3D_IN(i,j,3)) ) / &
    2670. 

  2670.                       (BOT_INPUT_HGT-Z3D_IN(i,j,3))
    2671. 

  2671. 

  2672.               IF (I .eq. Ilook .and. J .eq. Jlook) then
    2673. 

  2673.                write(message,*) 'p diff: ', BOT_INPUT_PRESS, PRESS3D_IN(i,j,3)
    2674. 

  2674.                CALL wrf_message(message)
    2675. 

  2675.                write(message,*) 'z diff: ', BOT_INPUT_HGT, Z3D_IN(i,j,3)
    2676. 

  2676.                CALL wrf_message(message)
    2677. 

  2677.               ENDIF
    2678. 

  2678. 	
    2679. 

  2679.             ELSE
    2680. 

  2680. 

  2681. !! Loop up to level 7 looking for a sufficiently thick layer
    2682. 

  2682. 

  2683.               FIND_THICK:  DO LL=4,7
    2684. 

  2684.                IF( abs(BOT_INPUT_PRESS - PRESS3D_IN(i,j,LL)) .gt. 290.) THEN
    2685. 

  2685.                  dlnpdz= (log(BOT_INPUT_PRESS)-log(PRESS3D_IN(i,j,LL)) ) / &
    2686. 

  2686.                    (BOT_INPUT_HGT-Z3D_IN(i,j,LL))
    2687. 

  2687.                 EXIT FIND_THICK
    2688. 

  2688.                ENDIF
    2689. 

  2689.               END DO FIND_THICK
    2690. 

  2690. 

  2691.             ENDIF
    2692. 

  2692. 

  2693.           ENDIF
    2694. 

  2694. 

  2695.         dum2d(I,J)= exp(log(BOT_INPUT_PRESS) + dlnpdz * &
    2696. 

  2696.                         (TERRAIN_HGT_T(I,J) - BOT_INPUT_HGT) )
    2697. 

  2697. 

  2698.          IF (dum2d(I,J) .lt. 50000. .or. dum2d(I,J) .gt. 108000.) THEN
    2699. 

  2699.            write(message,*) 'bad dum2d(b): ', I,J,DUM2D(I,J)
    2700. 

  2700.            CALL wrf_message(message)
    2701. 

  2701.            write(message,*) 'BOT_INPUT_PRESS, dlnpdz, TERRAIN_HGT_T, BOT_INPUT_HGT: ', &
    2702. 

  2702.                 BOT_INPUT_PRESS, dlnpdz, TERRAIN_HGT_T(I,J), BOT_INPUT_HGT
    2703. 

  2703.            CALL wrf_message(message)
    2704. 

  2704.            write(message,*) 'Z3D_IN: ', Z3D_IN(I,J,1:10)
    2705. 

  2705.            CALL wrf_message(message)
    2706. 

  2706.            write(message,*) 'PRESS3D_IN: ', PRESS3D_IN(I,J,1:10)
    2707. 

  2707.            CALL wrf_message(message)
    2708. 

  2708.          ENDIF
    2709. 

  2709. 

  2710.         ELSE ! target level bounded by input levels
    2711. 

  2711. 

  2712.           DO L=2,generic-1
    2713. 

  2713.             IF (TERRAIN_HGT_T(I,J) .gt. Z3D_IN(i,j,L) .AND. &
    2714. 

  2714.                   TERRAIN_HGT_T(I,J) .lt. Z3D_IN(i,j,L+1) ) THEN
    2715. 

  2715.                dlnpdz= (log(PRESS3D_IN(i,j,l))-log(PRESS3D_IN(i,j,L+1)) ) / &
    2716. 

  2716.                        (Z3D_IN(i,j,l)-Z3D_IN(i,j,L+1))
    2717. 

  2717.                dum2d(I,J)= log(PRESS3D_IN(i,j,l)) +   &
    2718. 

  2718.                            dlnpdz * (TERRAIN_HGT_T(I,J) - Z3D_IN(i,j,L) )
    2719. 

  2719.                dum2d(i,j)=exp(dum2d(i,j))
    2720. 

  2720.                IF (dum2d(I,J) .lt. 50000. .or. dum2d(I,J) .gt. 108000.) THEN
    2721. 

  2721.                  write(message,*) 'bad dum2d(c): ', I,J,DUM2D(I,J)
    2722. 

  2722.                  CALL wrf_message(message)
    2723. 

  2723.                ENDIF
    2724. 

  2724.             ENDIF
    2725. 

  2725.           ENDDO
    2726. 

  2726. 

  2727. !!! account for situation where BOT_INPUT_HGT < TERRAIN_HGT_T < Z3D_IN(:,2,:)
    2728. 

  2728.           IF (dum2d(I,J) .eq. -9 .AND. BOT_INPUT_HGT .lt. TERRAIN_HGT_T(I,J) &
    2729. 

  2729.               .AND. TERRAIN_HGT_T(I,J) .lt. Z3D_IN(I,J,2)) then
    2730. 

  2730. 

  2731.             IF (mod(I,50) .eq. 0 .AND. mod(J,50) .eq. 0) THEN
    2732. 

  2732.               write(message,*) 'I,J,BOT_INPUT_HGT, bot_pres, TERRAIN_HGT_T: ',  &
    2733. 

  2733.                  I,J,BOT_INPUT_HGT, BOT_INPUT_PRESS, TERRAIN_HGT_T(I,J)
    2734. 

  2734.               CALL wrf_message(message)
    2735. 

  2735.             ENDIF
    2736. 

  2736. 

  2737.             dlnpdz= (log(PSFC_IN(i,j))-log(PRESS3D_IN(i,j,2)) ) / &
    2738. 

  2738.                     (TOPO_IN(i,j)-Z3D_IN(i,j,2))
    2739. 

  2739.             dum2d(I,J)= log(PSFC_IN(i,j)) +   &
    2740. 

  2740.                         dlnpdz * (TERRAIN_HGT_T(I,J) - TOPO_IN(i,j) )
    2741. 

  2741.             dum2d(i,j)= exp(dum2d(i,j))
    2742. 

  2742.             IF (dum2d(I,J) .lt. 50000. .or. dum2d(I,J) .gt. 108000.) THEN
    2743. 

  2743.               write(message,*) 'bad dum2d(d): ', I,J,DUM2D(I,J)
    2744. 

  2744.               CALL wrf_message(message)
    2745. 

  2745.             ENDIF
    2746. 

  2746.           ENDIF
    2747. 

  2747. 

  2748.           IF (dum2d(I,J) .eq. -9.) THEN
    2749. 

  2749.             write(message,*) 'must have flukey situation in new ', I,J
    2750. 

  2750.             CALL wrf_message(message)
    2751. 

  2751.             write(message,*) 'I,J,BOT_INPUT_HGT, bot_pres, TERRAIN_HGT_T: ',  &
    2752. 

  2752.                        I,J,BOT_INPUT_HGT, BOT_INPUT_PRESS, TERRAIN_HGT_T(I,J)
    2753. 

  2753.             CALL wrf_message(message)
    2754. 

  2754. 

  2755.             DO L=1,generic-1
    2756. 

  2756.               IF ( TERRAIN_HGT_T(I,J) .eq. Z3D_IN(i,j,L) ) THEN
    2757. 

  2757. ! problematic with HGT_M substitution for "input" surface height?
    2758. 

  2758.                 dum2d(i,j)=PRESS3D_IN(I,J,L)
    2759. 

  2759.                 IF (dum2d(I,J) .lt. 50000. .or. dum2d(I,J) .gt. 108000.) THEN
    2760. 

  2760.                   write(message,*) 'bad dum2d(e): ', I,J,DUM2D(I,J)
    2761. 

  2761.                   CALL wrf_message(message)
    2762. 

  2762.                 ENDIF
    2763. 

  2763.               ENDIF
    2764. 

  2764.             ENDDO
    2765. 

  2765. 

  2766.             IF ( TERRAIN_HGT_T(I,J) .eq. TOPO_IN(I,J)) THEN
    2767. 

  2767.               dum2d(I,J)=PSFC_IN(I,J)
    2768. 

  2768.               IF (dum2d(I,J) .lt. 50000. .or. dum2d(I,J) .gt. 108000.) THEN
    2769. 

  2769.                 write(message,*) 'bad dum2d(grid%f): ', I,J,DUM2D(I,J)
    2770. 

  2770.                 CALL wrf_message(message)
    2771. 

  2771.               ENDIF
    2772. 

  2772.              write(message,*) 'matched input topo, psfc: ', I,J,TOPO_IN(I,J),PSFC_IN(I,J)
    2773. 

  2773.              CALL wrf_message(message)
    2774. 

  2774.             ENDIF
    2775. 

  2775. 

  2776.             IF (dum2d(I,J) .eq. -9.) THEN
    2777. 

  2777.               CALL wrf_error_fatal("quitting due to undefined surface pressure")
    2778. 

  2778.             ENDIF
    2779. 

  2779.           ENDIF
    2780. 

  2780. 

  2781.           DEFINED_PSFC(I,J)=.TRUE.
    2782. 

  2782. 

  2783. 	  IF (I .eq. Ilook .AND. J .eq. Jlook) THEN
    2784. 

  2784. 	    write(message,*) 'newstyle psfc: ', I,J,dum2d(I,J)
    2785. 

  2785.             CALL wrf_message(message)
    2786. 

  2786.           ENDIF
    2787. 

  2787. 

  2788.         ENDIF
    2789. 

  2789. 

  2790.         ENDDO I_loop
    2791. 

  2791.         ENDDO
    2792. 

  2792. 

  2793. !        write(message,*) 'psfc points (new style)'
    2794. 

  2794. !        CALL wrf_message(message)
    2795. 

  2795. 

  2796. !        DO J=min(JTE,JDE-1),JTS,-loopinc
    2797. 

  2797. !          write(message,633) (dum2d(I,J)/100.,I=ITS,min(ITE,IDE-1),iloopinc)
    2798. 

  2798. !          CALL wrf_message(message)
    2799. 

  2799. !        END DO
    2800. 

  2800. 

  2801.   633   format(35(f5.0,1x))
    2802. 

  2802. 

  2803.         write(message,*) 'PSFC extremes (new style)'
    2804. 

  2804.         CALL wrf_message(message)
    2805. 

  2805.         write(message,*) minval(dum2d,MASK=DEFINED_PSFC),maxval(dum2d,MASK=DEFINED_PSFC)
    2806. 

  2806.         CALL wrf_message(message)
    2807. 

  2807. 

  2808. !         IF (minval(dum2d,MASK=DEFINED_PSFC) .lt. 50000. .or. maxval(dum2d,MASK=DEFINED_PSFC) .gt. 108000.) THEN
    2809. 

  2809. 

  2810.         DO J=JTS,min(JTE,JDE-1)
    2811. 

  2811.          DO I=ITS,min(ITE,IDE-1)
    2812. 

  2812. 

  2813.           IF (DEFINED_PSFC(I,J) .AND. dum2d(I,J) .lt. 50000. ) THEN
    2814. 

  2814.             IF (TERRAIN_HGT_T(I,J) .gt. 4500.) THEN
    2815. 

  2815.               WRITE(message,*) 'low surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J)
    2816. 

  2816.               CALL wrf_debug(2,message)
    2817. 

  2817.             ELSE
    2818. 

  2818.               CALL wrf_error_fatal("quit due to unrealistic surface pressure")
    2819. 

  2819.             ENDIF
    2820. 

  2820.           ENDIF
    2821. 

  2821. 

  2822.           IF (DEFINED_PSFC(I,J) .AND. dum2d(I,J) .gt. 108000. ) THEN
    2823. 

  2823.             IF (TERRAIN_HGT_T(I,J) .lt. -10.) THEN
    2824. 

  2824.               WRITE(message,*) 'high surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J)
    2825. 

  2825.               CALL wrf_debug(2,message)
    2826. 

  2826.             ELSE
    2827. 

  2827.               CALL wrf_error_fatal("quit due to unrealistic surface pressure")
    2828. 

  2828.             ENDIF
    2829. 

  2829.           ENDIF
    2830. 

  2830. 

  2831.          END DO
    2832. 

  2832.         END DO
    2833. 

  2833. 

  2834. 

  2835. 

  2836. !! "traditional" isobaric only approach ------------------------------------------------
    2837. 

  2837. 

  2838.        ALLOCATE (DUM2DB(IMS:IME,JMS:JME))
    2839. 

  2839.        DO J=JMS,JME
    2840. 

  2840.         DO I=IMS,IME
    2841. 

  2841.          DUM2DB(I,J)=-9.
    2842. 

  2842.         END DO
    2843. 

  2843.        END DO
    2844. 

  2844. 

  2845.        DO J=JTS,min(JTE,JDE-1)
    2846. 

  2846.        DO I=ITS,min(ITE,IDE-1)
    2847. 

  2847. 

  2848.         IF (TERRAIN_HGT_T(I,J) .lt. Z3D_IN(i,j,2)) THEN ! targ below lowest
    2849. 

  2849. 

  2850.           IF ( abs(PRESS3D_IN(i,j,2)-PRESS3D_IN(i,j,3)) .gt. 290.) THEN
    2851. 

  2851.             dlnpdz= (log(PRESS3D_IN(i,j,2))-log(PRESS3D_IN(i,j,3)) ) / &
    2852. 

  2852.                     (Z3D_IN(i,j,2)-Z3D_IN(i,j,3))
    2853. 

  2853.           ELSE
    2854. 

  2854.             dlnpdz= (log(PRESS3D_IN(i,j,2))-log(PRESS3D_IN(i,j,4)) ) / &
    2855. 

  2855.                     (Z3D_IN(i,j,2)-Z3D_IN(i,j,4))
    2856. 

  2856.           ENDIF
    2857. 

  2857. 

  2858.           DUM2DB(I,J)= exp( log(PRESS3D_IN(i,j,2)) + dlnpdz * &
    2859. 

  2859.                            (TERRAIN_HGT_T(I,J) - Z3D_IN(i,j,2)) )
    2860. 

  2860. 

  2861. 	  IF (I .eq. Ilook .and. J .eq. Jlook) THEN
    2862. 

  2862. 	    write(message,*) 'I,K, trad: dlnpdz, press_in(2), terrain_t, Z3D_IN(2): ', I,J,dlnpdz, &
    2863. 

  2863.                              PRESS3D_IN(i,j,2), TERRAIN_HGT_T(I,J), Z3D_IN(i,j,2)
    2864. 

  2864.             CALL wrf_message(message)
    2865. 

  2865.           ENDIF
    2866. 

  2866. 

  2867.           DEFINED_PSFCB(i,j)=.true.
    2868. 

  2868. 

  2869.         ELSEIF (TERRAIN_HGT_T(I,J) .gt. Z3D_IN(i,j,2)) THEN ! target level bounded by input levels
    2870. 

  2870. 

  2871.         DO L=2,generic-1
    2872. 

  2872.           IF (TERRAIN_HGT_T(I,J) .gt. Z3D_IN(i,j,L) .AND. &
    2873. 

  2873.               TERRAIN_HGT_T(I,J) .lt. Z3D_IN(i,j,L+1) ) THEN
    2874. 

  2874. 

  2875.             dlnpdz= (log(PRESS3D_IN(i,j,l))-log(PRESS3D_IN(i,j,L+1)) ) / &
    2876. 

  2876.                     (Z3D_IN(i,j,l)-Z3D_IN(i,j,L+1))
    2877. 

  2877. 

  2878.             DUM2DB(I,J)= log(PRESS3D_IN(i,j,l)) +   &
    2879. 

  2879.                          dlnpdz * (TERRAIN_HGT_T(I,J) - Z3D_IN(i,j,L) )
    2880. 

  2880.             DUM2DB(i,j)=exp(DUM2DB(i,j))
    2881. 

  2881. 

  2882. 	    DEFINED_PSFCB(i,j)=.true.
    2883. 

  2883. 

  2884.             IF (DUM2DB(I,J) .lt. 13000.) THEN
    2885. 

  2885.               write(message,*) 'I,J,L,terrain,Z3d(L),z3d(L+1),p3d(L),p3d(l+1): ', I,J,L, &
    2886. 

  2886.                                 TERRAIN_HGT_T(I,J),Z3D_IN(I,J,L),Z3D_IN(I,J,L+1),PRESS3D_IN(I,J,L), &
    2887. 

  2887.                                 PRESS3D_IN(I,J,L+1)
    2888. 

  2888.               CALL wrf_error_fatal(message)
    2889. 

  2889.             ENDIF
    2890. 

  2890.           ENDIF
    2891. 

  2891.         ENDDO
    2892. 

  2892. 

  2893.         ELSEIF (TERRAIN_HGT_T(I,J) .eq. Z3D_IN(i,j,2)) THEN
    2894. 

  2894.           DUM2DB(i,j)=PRESS3D_IN(I,J,2)
    2895. 

  2895. 	  DEFINED_PSFCB(i,j)=.true.
    2896. 

  2896.         ENDIF
    2897. 

  2897. 

  2898.         IF (DUM2DB(I,J) .eq. -9.) THEN
    2899. 

  2899.           write(message,*) 'must have flukey situation in trad ', I,J
    2900. 

  2900.           CALL wrf_message(message)
    2901. 

  2901.           DO L=1,generic-1
    2902. 

  2902.             IF ( TERRAIN_HGT_T(I,J) .eq. Z3D_IN(i,j,L) ) THEN
    2903. 

  2903.               DUM2DB(i,j)=PRESS3D_IN(I,J,L)
    2904. 

  2904.               DEFINED_PSFCB(i,j)=.true.
    2905. 

  2905.             ENDIF
    2906. 

  2906.           ENDDO
    2907. 

  2907.         ENDIF
    2908. 

  2908. 

  2909.         IF (DUM2DB(I,J) .eq. -9.) THEN
    2910. 

  2910.           write(message,*) 'HOPELESS PSFC, I QUIT'
    2911. 

  2911.           CALL wrf_error_fatal(message)
    2912. 

  2912.         ENDIF
    2913. 

  2913. 

  2914. 	if (I .eq. Ilook .and. J .eq. Jlook) THEN
    2915. 

  2915. 	  write(message,*) ' traditional psfc: ', I,J,DUM2DB(I,J)
    2916. 

  2916.           CALL wrf_message(message)
    2917. 

  2917.         ENDIF
    2918. 

  2918. 

  2919.        ENDDO
    2920. 

  2920.        ENDDO
    2921. 

  2921. 

  2922. !       write(message,*) 'psfc points (traditional)'
    2923. 

  2923. !       CALL wrf_message(message)
    2924. 

  2924. !       DO J=min(JTE,JDE-1),JTS,-loopinc
    2925. 

  2925. !         write(message,633) (DUM2DB(I,J)/100.,I=its,min(ite,IDE-1),iloopinc)
    2926. 

  2926. !         CALL wrf_message(message)
    2927. 

  2927. !       ENDDO
    2928. 

  2928. 

  2929.        write(message,*) 'PSFC extremes (traditional)'
    2930. 

  2930.        CALL wrf_message(message)
    2931. 

  2931.        write(message,*) minval(DUM2DB,MASK=DEFINED_PSFCB),maxval(DUM2DB,MASK=DEFINED_PSFCB)
    2932. 

  2932.        CALL wrf_message(message)
    2933. 

  2933. 

  2934.         DO J=JTS,min(JTE,JDE-1)
    2935. 

  2935.          DO I=ITS,min(ITE,IDE-1)
    2936. 

  2936. 

  2937.           IF (DEFINED_PSFCB(I,J) .AND. dum2db(I,J) .lt. 50000. ) THEN
    2938. 

  2938.             IF (TERRAIN_HGT_T(I,J) .gt. 4500.) THEN
    2939. 

  2939.               WRITE(message,*) 'low surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J)
    2940. 

  2940.               CALL wrf_debug(2,message)
    2941. 

  2941.             ELSE
    2942. 

  2942.               CALL wrf_error_fatal("quit due to unrealistic surface pressure")
    2943. 

  2943.             ENDIF
    2944. 

  2944.           ENDIF
    2945. 

  2945. 

  2946.           IF (DEFINED_PSFCB(I,J) .AND. dum2db(I,J) .gt. 108000. ) THEN
    2947. 

  2947.             IF (TERRAIN_HGT_T(I,J) .lt. -10.) THEN
    2948. 

  2948.               WRITE(message,*) 'high surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J)
    2949. 

  2949.               CALL wrf_debug(2,message)
    2950. 

  2950.             ELSE
    2951. 

  2951.               CALL wrf_error_fatal("quit due to unrealistic surface pressure")
    2952. 

  2952.             ENDIF
    2953. 

  2953.           ENDIF
    2954. 

  2954. 

  2955. !          IF (DEFINED_PSFCB(I,J) .AND. ( dum2db(I,J) .lt. 50000. .OR. dum2db(I,J) .gt. 108000. )) THEN
    2956. 

  2956. !          IF (TERRAIN_HGT_T(I,J) .gt. -10. .and. TERRAIN_HGT_T(I,J) .lt. 5000.) THEN
    2957. 

  2957. !            write(0,*) 'I,J, terrain_hgt_t, dum2db: ', I,J, terrain_hgt_t(I,J),dum2db(I,J)
    2958. 

  2958. !	    CALL wrf_error_fatal("quit due to unrealistic surface pressure")
    2959. 

  2959. !          ELSE
    2960. 

  2960. !            WRITE(message,*) 'surface pressure allowed because surface height is extreme value of: ', TERRAIN_HGT_T(I,J)
    2961. 

  2961. !            CALL wrf_debug(2,message)
    2962. 

  2962. !          ENDIF
    2963. 

  2963. !          ENDIF
    2964. 

  2964. 

  2965.          ENDDO
    2966. 

  2966.         ENDDO
    2967. 

  2967. 

  2968. !!!!! end traditional
    2969. 

  2969. 

  2970.        DO J=JTS,min(JTE,JDE-1)
    2971. 

  2971.        DO I=ITS,min(ITE,IDE-1)
    2972. 

  2972.          IF (DEFINED_PSFCB(I,J) .and. DEFINED_PSFC(I,J)) THEN
    2973. 

  2973. 

  2974.           IF (  abs(dum2d(I,J)-DUM2DB(I,J)) .gt. 400.) THEN
    2975. 

  2975. 	     write(message,*) 'BIG DIFF I,J, dum2d, DUM2DB: ', I,J,dum2d(I,J),DUM2DB(I,J)
    2976. 

  2976.              CALL wrf_message(message)
    2977. 

  2977.           ENDIF
    2978. 

  2978. 

  2979. !! do we have enough confidence in new style to give it more than 50% weight?
    2980. 

  2980.           psfc_out(I,J)=0.5*(dum2d(I,J)+DUM2DB(I,J))
    2981. 

  2981. 

  2982.          ELSEIF (DEFINED_PSFC(I,J)) THEN
    2983. 

  2983.            psfc_out(I,J)=dum2d(I,J)
    2984. 

  2984.          ELSEIF (DEFINED_PSFCB(I,J)) THEN
    2985. 

  2985.            psfc_out(I,J)=DUM2DB(I,J)
    2986. 

  2986.          ELSE
    2987. 

  2987. 	   write(message,*) 'I,J,dum2d,DUM2DB: ', I,J,dum2d(I,J),DUM2DB(I,J)
    2988. 

  2988.            CALL wrf_message(message)
    2989. 

  2989. 	   write(message,*) 'I,J,DEFINED_PSFC(I,J),DEFINED_PSFCB(I,J): ', I,J,DEFINED_PSFC(I,J),DEFINED_PSFCB(I,J)
    2990. 

  2990.            CALL wrf_message(message)
    2991. 

  2991. 	   call wrf_error_fatal("psfc_out completely undefined")
    2992. 

  2992.          ENDIF
    2993. 

  2993. 

  2994. 	IF (I .eq. Ilook .AND. J .eq. Jlook) THEN
    2995. 

  2995. 	  write(message,*) ' combined psfc: ', I,J,psfc_out(I,J)
    2996. 

  2996.           CALL wrf_message(message)
    2997. 

  2997.         ENDIF
    2998. 

  2998. 

  2999.           IF (psfc_out(I,J) .lt. 50000. ) THEN
    3000. 

  3000.             IF (TERRAIN_HGT_T(I,J) .gt. 4500.) THEN
    3001. 

  3001.               WRITE(message,*) 'low surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J)
    3002. 

  3002.               CALL wrf_debug(2,message)
    3003. 

  3003.             ELSE
    3004. 

  3004. 	      write(message,*) 'possibly bad combo on psfc_out: ', I,J, psfc_out(I,J)
    3005. 

  3005.               CALL wrf_debug(2,message)
    3006. 

  3006. 	      write(message,*) 'DEFINED_PSFC, dum2d: ', DEFINED_PSFC(I,J),dum2d(I,J)
    3007. 

  3007.               CALL wrf_debug(2,message)
    3008. 

  3008. 	      write(message,*) 'DEFINED_PSFCB, DUM2DB: ', DEFINED_PSFCB(I,J),DUM2DB(I,J)
    3009. 

  3009.               CALL wrf_debug(2,message)
    3010. 

  3010.               CALL wrf_error_fatal("quit due to unrealistic surface pressure")
    3011. 

  3011.             ENDIF
    3012. 

  3012.           ENDIF
    3013. 

  3013. 

  3014.           IF (psfc_out(I,J) .gt. 108000. ) THEN
    3015. 

  3015.             IF (TERRAIN_HGT_T(I,J) .lt. -10.) THEN
    3016. 

  3016.               WRITE(message,*) 'high surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J)
    3017. 

  3017.               CALL wrf_debug(2,message)
    3018. 

  3018.             ELSE
    3019. 

  3019. 	      write(message,*) 'possibly bad combo on psfc_out: ', I,J, psfc_out(I,J)
    3020. 

  3020.               CALL wrf_debug(2,message)
    3021. 

  3021. 	      write(message,*) 'DEFINED_PSFC, dum2d: ', DEFINED_PSFC(I,J),dum2d(I,J)
    3022. 

  3022.               CALL wrf_debug(2,message)
    3023. 

  3023. 	      write(message,*) 'DEFINED_PSFCB, DUM2DB: ', DEFINED_PSFCB(I,J),DUM2DB(I,J)
    3024. 

  3024.               CALL wrf_debug(2,message)
    3025. 

  3025.               CALL wrf_error_fatal("quit due to unrealistic surface pressure")
    3026. 

  3026.             ENDIF
    3027. 

  3027.           ENDIF
    3028. 

  3028. 

  3029.        ENDDO
    3030. 

  3030.        ENDDO
    3031. 

  3031. 

  3032. 	deallocate(dum2d,dum2db)
    3033. 

  3033. 

  3034. 	END SUBROUTINE compute_nmm_surfacep
    3035. 

  3035. 

  3036. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    3037. 

  3037. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    3038. 

  3038. 

  3039.       SUBROUTINE compute_3d_pressure(psfc_out,SGML1,SGML2,pdtop,pt       &
    3040. 

  3040.      &,                              pd,p3d_out                          &
    3041. 

  3041.      &,                              IDS,IDE,JDS,JDE,KDS,KDE             &
    3042. 

  3042.      &,                              IMS,IME,JMS,JME,KMS,KME             &
    3043. 

  3043.      &,                              ITS,ITE,JTS,JTE,KTS,KTE )
    3044. 

  3044. 

  3045. 

  3046.         INTEGER          :: IDS,IDE,JDS,JDE,KDS,KDE
    3047. 

  3047.         INTEGER          :: IMS,IME,JMS,JME,KMS,KME
    3048. 

  3048.         INTEGER          :: ITS,ITE,JTS,JTE,KTS,KTE
    3049. 

  3049. 

  3050.         REAL, INTENT(IN) :: psfc_out(IMS:IME,JMS:JME)
    3051. 

  3051.         REAL, INTENT(IN) :: SGML1(KDE),SGML2(KDE),pdtop,pt
    3052. 

  3052. 

  3053.         REAL, INTENT(OUT):: p3d_out(IMS:IME,JMS:JME,KDS:KDE-1)
    3054. 

  3054.         REAL, INTENT(OUT):: pd(IMS:IME,JMS:JME)
    3055. 

  3055. 

  3056.         CHARACTER (len=255) :: message
    3057. 

  3057. 

  3058. !	write(message,*) 'pdtop, pt, psfc_out(1,1): ', pdtop, pt, psfc_out(1,1)
    3059. 

  3059. !        CALL wrf_message(message)
    3060. 

  3060. 

  3061.         DO J=JTS,min(JTE,JDE-1)
    3062. 

  3062.           DO I=ITS,min(ITE,IDE-1)
    3063. 

  3063.              pd(I,J)=psfc_out(I,J)-pdtop-pt
    3064. 

  3064.           ENDDO
    3065. 

  3065.         ENDDO
    3066. 

  3066. 

  3067.         DO J=JTS,min(JTE,JDE-1)
    3068. 

  3068.          DO K=KDS,KDE-1
    3069. 

  3069.           DO I=ITS,min(ITE,IDE-1)
    3070. 

  3070.            p3d_out(I,J,K)=pd(I,J)*SGML2(K)+pdtop*SGML1(K)+pt
    3071. 

  3071. 

  3072. 	IF (p3d_out(I,J,K) .ge. psfc_out(I,J) .or. p3d_out(I,J,K) .le. pt) THEN
    3073. 

  3073.            write(message,*) 'I,K,J,p3d_out: ', I,K,J,p3d_out(I,J,K)
    3074. 

  3074.            CALL wrf_error_fatal(message)
    3075. 

  3075.  	ENDIF
    3076. 

  3076. 

  3077.           ENDDO
    3078. 

  3078.          ENDDO
    3079. 

  3079.         ENDDO
    3080. 

  3080. 

  3081. 	END SUBROUTINE compute_3d_pressure
    3082. 

  3082. 

  3083. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    3084. 

  3084. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    3085. 

  3085. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    3086. 

  3086. 

  3087.   SUBROUTINE interp_press2press_lin(press_in,press_out, &
    3088. 

  3088.                                     data_in, data_out,generic          &
    3089. 

  3089.      &,                             extrapolate,ignore_lowest,TFIELD    &
    3090. 

  3090.      &,                             IDS,IDE,JDS,JDE,KDS,KDE             &
    3091. 

  3091.      &,                             IMS,IME,JMS,JME,KMS,KME             &
    3092. 

  3092.      &,                             ITS,ITE,JTS,JTE,KTS,KTE, internal_time )
    3093. 

  3093. 

  3094.     ! Interpolates data from one set of pressure surfaces to
    3095. 

  3095.     ! another set of pressures
    3096. 

  3096. 

  3097.     INTEGER                            :: IDS,IDE,JDS,JDE,KDS,KDE
    3098. 

  3098.     INTEGER                            :: IMS,IME,JMS,JME,KMS,KME
    3099. 

  3099.     INTEGER                            :: ITS,ITE,JTS,JTE,KTS,KTE,generic
    3100. 

  3100.     INTEGER                            :: internal_time
    3101. 

  3101. 

  3102. !    REAL, INTENT(IN)                   :: press_in(IMS:IME,generic,JMS:JME)
    3103. 

  3103.     REAL, INTENT(IN)                   :: press_in(IMS:IME,JMS:JME,generic)
    3104. 

  3104.     REAL, INTENT(IN)                   :: press_out(IMS:IME,JMS:JME,KDS:KDE-1)
    3105. 

  3105. !    REAL, INTENT(IN)                   :: data_in(IMS:IME,generic,JMS:JME)
    3106. 

  3106.     REAL, INTENT(IN)                   :: data_in(IMS:IME,JMS:JME,generic)
    3107. 

  3107.     REAL, INTENT(OUT)                  :: data_out(IMS:IME,JMS:JME,KMS:KME)
    3108. 

  3108.     LOGICAL, INTENT(IN)                :: extrapolate, ignore_lowest, TFIELD
    3109. 

  3109.     LOGICAL                            :: col_smooth
    3110. 

  3110. 

  3111.     INTEGER                            :: i,j
    3112. 

  3112.     INTEGER                            :: k,kk
    3113. 

  3113.     REAL                               :: desired_press
    3114. 

  3114.     REAL                               :: dvaldlnp,dlnp,tadiabat,tiso
    3115. 

  3115. 

  3116.     REAL, PARAMETER                    :: ADIAFAC=9.81/1004.
    3117. 

  3117.     REAL, PARAMETER                    :: TSTEXTRAPFAC=.0065
    3118. 

  3118. 

  3119. 

  3120. 

  3121.       DO K=KMS,KME
    3122. 

  3122.       DO J=JMS,JME
    3123. 

  3123.       DO I=IMS,IME
    3124. 

  3124.         DATA_OUT(I,J,K)=-99999.9
    3125. 

  3125.       ENDDO
    3126. 

  3126.       ENDDO
    3127. 

  3127.       ENDDO
    3128. 

  3128. 

  3129.     IF (ignore_lowest) then
    3130. 

  3130.        LMIN=2
    3131. 

  3131.     ELSE
    3132. 

  3132.        LMIN=1
    3133. 

  3133.     ENDIF
    3134. 

  3134. 

  3135.     DO j = JTS, min(JTE,JDE-1)
    3136. 

  3136.       test_i: DO i = ITS, min(ITE,IDE-1)
    3137. 

  3137. 

  3138.      IF (internal_time_loop .gt. 1) THEN
    3139. 

  3139.         IF (J .ne. JDS .and. J .ne. JDE-1 .and. &
    3140. 

  3140.           I .ne. IDS .and. I .ne. IDE-1 ) THEN
    3141. 

  3141. !! not on boundary
    3142. 

  3142.           CYCLE test_i
    3143. 

  3143.         ENDIF
    3144. 

  3144.      ENDIF
    3145. 

  3145. 

  3146. 

  3147.        col_smooth=.false.
    3148. 

  3148. 

  3149.         output_loop: DO k = KDS,KDE-1
    3150. 

  3150. 

  3151.           desired_press = press_out(i,j,k)
    3152. 

  3152. 

  3153.         if (K .gt. KDS) then
    3154. 

  3154. 	if (TFIELD .and. col_smooth .and. desired_press .le. press_in(i,j,LMIN) &
    3155. 

  3155.                                     .and. press_out(i,j,k-1) .ge. press_in(i,j,LMIN)) then
    3156. 

  3156. 	  MAX_SMOOTH=K
    3157. 

  3157. !	  write(message,*) 'I,J, MAX_SMOOTH: ', I,J, MAX_SMOOTH
    3158. 

  3158. !         CALL wrf_debug(100,message)
    3159. 

  3159.         endif
    3160. 

  3160.         endif
    3161. 

  3161. 

  3162. ! keep track of where the extrapolation begins
    3163. 

  3163. 

  3164.           IF (desired_press .GT. press_in(i,j,LMIN)) THEN
    3165. 

  3165.            IF (TFIELD .and. K .eq. 1  .and. (desired_press - press_in(i,j,LMIN)) .gt. 3000.) then
    3166. 

  3166.             col_smooth=.TRUE.   ! due to large extrapolation distance
    3167. 

  3167.            ENDIF
    3168. 

  3168. 	
    3169. 

  3169. 

  3170.             IF ((desired_press - press_in(i,j,LMIN)).LT. 50.) THEN ! 0.5 mb
    3171. 

  3171.                data_out(i,j,k) = data_in(i,j,LMIN)
    3172. 

  3172.             ELSE
    3173. 

  3173.               IF (extrapolate) THEN
    3174. 

  3174.                 ! Extrapolate downward because desired P level is below
    3175. 

  3175.                 ! the lowest level in our input data.  Extrapolate using simple
    3176. 

  3176.                 ! 1st derivative of value with respect to ln P for the bottom 2
    3177. 

  3177.                 ! input layers.
    3178. 

  3178. 

  3179.                 ! Add a check to make sure we are not using the gradient of
    3180. 

  3180.                 ! a very thin layer
    3181. 

  3181. 

  3182.                 if (TFIELD) then
    3183. 

  3183.                   tiso=0.5*(data_in(i,j,1)+data_in(i,j,2))
    3184. 

  3184.                 endif
    3185. 

  3185. 

  3186. 

  3187.                 IF ( (press_in(i,j,LMIN)-press_in(i,j,LMIN+1)) .GT. 500.) THEN ! likely isobaric data
    3188. 

  3188.                   dlnp     = log(press_in(i,j,LMIN))-log(press_in(i,j,LMIN+1))
    3189. 

  3189.                   dvaldlnp = (data_in(i,j,LMIN) - data_in(i,j,LMIN+1)) / dlnp
    3190. 

  3190.                 ELSE                                                           ! assume terrain following
    3191. 

  3191.                   dlnp     = log(press_in(i,j,LMIN))-log(press_in(i,j,LMIN+5))
    3192. 

  3192.                   dvaldlnp = (data_in(i,j,LMIN) - data_in(i,j,LMIN+5)) / dlnp
    3193. 

  3193.                 ENDIF
    3194. 

  3194.                 data_out(i,j,k) = data_in(i,j,LMIN) + dvaldlnp * &
    3195. 

  3195.                                ( log(desired_press)-log(press_in(i,j,LMIN)) )
    3196. 

  3196. 

  3197. 	if (TFIELD .and. data_out(i,j,k) .lt. tiso-0.2) then
    3198. 

  3198. 

  3199. ! restrict slope to -1K/10 hPa
    3200. 

  3200.           dvaldlnp=max(dvaldlnp, -1.0/ &
    3201. 

  3201.                                 log( press_in(i,j,LMIN) / &
    3202. 

  3202.                                    ( press_in(i,j,LMIN)-1000.)  ))
    3203. 

  3203. 

  3204.           data_out(I,J,K)= data_in(i,j,LMIN) + dvaldlnp * &
    3205. 

  3205.                                ( log(desired_press)-log(press_in(i,j,LMIN)) )
    3206. 

  3206. 

  3207.         elseif (TFIELD .and. data_out(i,j,k) .gt. tiso+0.2) then
    3208. 

  3208. 

  3209. ! restrict slope to +0.8K/10 hPa
    3210. 

  3210.           dvaldlnp=min(dvaldlnp, 0.8/ &
    3211. 

  3211.                                 log( press_in(i,j,LMIN) / &
    3212. 

  3212.                                    ( press_in(i,j,LMIN)-1000.)  ))
    3213. 

  3213. 

  3214.           data_out(I,J,K)= data_in(i,j,LMIN) + dvaldlnp * &
    3215. 

  3215.                                ( log(desired_press)-log(press_in(i,j,LMIN)) )
    3216. 

  3216. 

  3217.          endif
    3218. 

  3218. 

  3219.               ELSE
    3220. 

  3220.                 data_out(i,j,k) = data_in(i,j,LMIN)
    3221. 

  3221.               ENDIF
    3222. 

  3222.             ENDIF
    3223. 

  3223.           ELSE IF (desired_press .LT. press_in(i,j,generic)) THEN
    3224. 

  3224.             IF ( (press_in(i,j,generic) - desired_press) .LT. 10.) THEN
    3225. 

  3225.                data_out(i,j,k) = data_in(i,j,generic)
    3226. 

  3226.             ELSE
    3227. 

  3227.               IF (extrapolate) THEN
    3228. 

  3228.                 ! Extrapolate upward
    3229. 

  3229.                 IF ((press_in(i,j,generic-1)-press_in(i,j,generic)).GT.50.) THEN
    3230. 

  3230.                   dlnp    =log(press_in(i,j,generic))-log(press_in(i,j,generic-1))
    3231. 

  3231.                   dvaldlnp=(data_in(i,j,generic)-data_in(i,j,generic-1))/dlnp
    3232. 

  3232.                 ELSE
    3233. 

  3233.                   dlnp    =log(press_in(i,j,generic))-log(press_in(i,j,generic-2))
    3234. 

  3234.                   dvaldlnp=(data_in(i,j,generic)-data_in(i,j,generic-2))/dlnp
    3235. 

  3235.                 ENDIF
    3236. 

  3236.                 data_out(i,j,k) =  data_in(i,j,generic) + &
    3237. 

  3237.                   dvaldlnp * (log(desired_press)-log(press_in(i,j,generic)))
    3238. 

  3238.               ELSE
    3239. 

  3239.                 data_out(i,j,k) = data_in(i,j,generic)
    3240. 

  3240.               ENDIF
    3241. 

  3241.             ENDIF
    3242. 

  3242.           ELSE
    3243. 

  3243.             ! We can trap between two levels and linearly interpolate
    3244. 

  3244. 

  3245.             input_loop:  DO kk = LMIN, generic-1
    3246. 

  3246.               IF (desired_press .EQ. press_in(i,j,kk) )THEN
    3247. 

  3247.                 data_out(i,j,k) = data_in(i,j,kk)
    3248. 

  3248.                 EXIT input_loop
    3249. 

  3249.               ELSE IF ( (desired_press .LT. press_in(i,j,kk)) .AND. &
    3250. 

  3250.                         (desired_press .GT. press_in(i,j,kk+1)) ) THEN
    3251. 

  3251. 

  3252. !       do trapped in lnp
    3253. 

  3253. 

  3254.          dlnp = log(press_in(i,j,kk)) - log(press_in(i,j,kk+1))
    3255. 

  3255.          dvaldlnp = (data_in(i,j,kk)-data_in(i,j,kk+1))/dlnp
    3256. 

  3256.          data_out(i,j,k) = data_in(i,j,kk+1)+ &
    3257. 

  3257.                            dvaldlnp*(log(desired_press)-log(press_in(i,j,kk+1)))
    3258. 

  3258. 

  3259.                 EXIT input_loop
    3260. 

  3260.               ENDIF
    3261. 

  3261. 

  3262.             ENDDO input_loop
    3263. 

  3263.           ENDIF
    3264. 

  3264.         ENDDO output_loop
    3265. 

  3265. 

  3266. 	if (col_smooth) then
    3267. 

  3267.        do K=max(KDS,MAX_SMOOTH-4),MAX_SMOOTH+4
    3268. 

  3268.        data_out(I,J,K)=0.5*(data_out(I,J,K)+data_out(I,J,K+1))
    3269. 

  3269.        enddo
    3270. 

  3270.         endif
    3271. 

  3271. 

  3272.       ENDDO test_i
    3273. 

  3273.     ENDDO
    3274. 

  3274.   END SUBROUTINE interp_press2press_lin
    3275. 

  3275. 

  3276.   SUBROUTINE wind_adjust(press_in,press_out, &
    3277. 

  3277.                                     U_in, V_in,U_out,V_out           &
    3278. 

  3278.      &,                             generic,depth_replace    &
    3279. 

  3279.      &,                             IDS,IDE,JDS,JDE,KDS,KDE             &
    3280. 

  3280.      &,                             IMS,IME,JMS,JME,KMS,KME             &
    3281. 

  3281.      &,                             ITS,ITE,JTS,JTE,KTS,KTE )
    3282. 

  3282. 

  3283.     INTEGER                            :: IDS,IDE,JDS,JDE,KDS,KDE
    3284. 

  3284.     INTEGER                            :: IMS,IME,JMS,JME,KMS,KME
    3285. 

  3285.     INTEGER                            :: ITS,ITE,JTS,JTE,KTS,KTE,generic
    3286. 

  3286.     INTEGER                            :: MAXLIN,MAXLOUT
    3287. 

  3287. 

  3288.     REAL, INTENT(IN)                   :: press_in(IMS:IME,JMS:JME,generic)
    3289. 

  3289.     REAL, INTENT(IN)                   :: press_out(IMS:IME,JMS:JME,KDS:KDE-1)
    3290. 

  3290.     REAL, INTENT(IN)                   :: U_in(IMS:IME,JMS:JME,generic)
    3291. 

  3291.     REAL, INTENT(IN)                   :: V_in(IMS:IME,JMS:JME,generic)
    3292. 

  3292.     REAL, INTENT(INOUT)                :: U_out(IMS:IME,KMS:KME,JMS:JME)
    3293. 

  3293.     REAL, INTENT(INOUT)                :: V_out(IMS:IME,KMS:KME,JMS:JME)
    3294. 

  3294.     REAL                               :: p1d_in(generic)
    3295. 

  3295.     REAL                               :: p1d_out(KDS:KDE-1)
    3296. 

  3296. 

  3297. 

  3298.     DO j = JTS, min(JTE,JDE-1)
    3299. 

  3299.       DO i = ITS, min(ITE,IDE-1)
    3300. 

  3300. 

  3301. !        IF (press_out(I,J,1) .lt. press_in(I,J,2)) then
    3302. 

  3302.          IF(  (press_in(I,J,2)-press_out(I,J,1)) .gt. 200.) then
    3303. 

  3303. 

  3304.         U_out(I,1,J)=U_in(I,J,2)
    3305. 

  3305.         V_out(I,1,J)=V_in(I,J,2)
    3306. 

  3306. 

  3307.    INLOOP: DO L=2,generic
    3308. 

  3308. 	p1d_in(L)=-9999.
    3309. 

  3309.         IF (  (press_in(I,J,2)-press_in(I,J,L)) .lt. depth_replace) THEN
    3310. 

  3310.           p1d_in(L)=(press_in(I,J,2)-press_in(I,J,L))
    3311. 

  3311.           MAXLIN=L
    3312. 

  3312.         ELSE
    3313. 

  3313.           p1d_in(L)=(press_in(I,J,2)-press_in(I,J,L))
    3314. 

  3314.           EXIT INLOOP
    3315. 

  3315.         ENDIF
    3316. 

  3316.     END DO INLOOP
    3317. 

  3317. 

  3318.    OUTLOOP: DO L=KDS,KDE-1
    3319. 

  3319. 	p1d_out(L)=-9999.
    3320. 

  3320.         IF (  (press_out(I,J,1)-press_out(I,J,L)) .lt. depth_replace) THEN
    3321. 

  3321.           p1d_out(L)=(press_out(I,J,1)-press_out(I,J,L))
    3322. 

  3322.           MAXLOUT=L
    3323. 

  3323.         ELSE
    3324. 

  3324.           EXIT OUTLOOP
    3325. 

  3325.         ENDIF
    3326. 

  3326.     END DO OUTLOOP
    3327. 

  3327. 

  3328.         DO L=1,MAXLOUT
    3329. 

  3329. 	ptarg=p1d_out(L)
    3330. 

  3330. 

  3331.     FINDLOOP:   DO LL=2,MAXLIN
    3332. 

  3332. 

  3333.          if (p1d_in(LL) .lt. ptarg .and. p1d_in(LL+1) .gt. ptarg) then
    3334. 

  3334. 

  3335.            dlnp=log(p1d_in(LL))-log(p1d_in(LL+1))
    3336. 

  3336.            dudlnp=(U_in(I,J,LL)-U_in(I,J,LL+1))/dlnp
    3337. 

  3337.            dvdlnp=(V_in(I,J,LL)-V_in(I,J,LL+1))/dlnp
    3338. 

  3338.            U_out(I,L,J)=U_in(I,J,LL)+dudlnp*(log(ptarg)-log(p1d_in(LL)))
    3339. 

  3339.            V_out(I,L,J)=V_in(I,J,LL)+dvdlnp*(log(ptarg)-log(p1d_in(LL)))
    3340. 

  3340. 

  3341.            EXIT FINDLOOP
    3342. 

  3342.          endif
    3343. 

  3343. 

  3344.    END DO FINDLOOP
    3345. 

  3345.         END DO   ! MAXLOUT loop
    3346. 

  3346. 

  3347. 

  3348.         ENDIF
    3349. 

  3349. 

  3350.       ENDDO
    3351. 

  3351.     ENDDO
    3352. 

  3352. 

  3353. 

  3354. 

  3355.   END SUBROUTINE wind_adjust
    3356. 

  3356. !--------------------------------------------------------------------
    3357. 

  3357. 

  3358.   SUBROUTINE interp_press2press_log(press_in,press_out, &
    3359. 

  3359.                                     data_in, data_out, generic          &
    3360. 

  3360.      &,                             extrapolate,ignore_lowest           &
    3361. 

  3361.      &,                             IDS,IDE,JDS,JDE,KDS,KDE             &
    3362. 

  3362.      &,                             IMS,IME,JMS,JME,KMS,KME             &
    3363. 

  3363.      &,                             ITS,ITE,JTS,JTE,KTS,KTE, internal_time )
    3364. 

  3364. 

  3365.     ! Interpolates ln(data) from one set of pressure surfaces to
    3366. 

  3366.     ! another set of pressures
    3367. 

  3367. 

  3368.     INTEGER                            :: IDS,IDE,JDS,JDE,KDS,KDE
    3369. 

  3369.     INTEGER                            :: IMS,IME,JMS,JME,KMS,KME
    3370. 

  3370.     INTEGER                            :: ITS,ITE,JTS,JTE,KTS,KTE,generic
    3371. 

  3371.     INTEGER                            :: internal_time
    3372. 

  3372. 

  3373. !    REAL, INTENT(IN)                   :: press_in(IMS:IME,generic,JMS:JME)
    3374. 

  3374.     REAL, INTENT(IN)                   :: press_in(IMS:IME,JMS:JME,generic)
    3375. 

  3375.     REAL, INTENT(IN)                   :: press_out(IMS:IME,JMS:JME,KDS:KDE-1)
    3376. 

  3376. !    REAL, INTENT(IN)                   :: data_in(IMS:IME,generic,JMS:JME)
    3377. 

  3377. !    REAL, INTENT(IN)                   :: data_in(IMS:IME,JMS:JME,generic)
    3378. 

  3378.     REAL                               :: data_in(IMS:IME,JMS:JME,generic)
    3379. 

  3379.     REAL, INTENT(OUT)                  :: data_out(IMS:IME,JMS:JME,KMS:KME)
    3380. 

  3380.     LOGICAL, INTENT(IN)                :: extrapolate, ignore_lowest
    3381. 

  3381. 

  3382.     INTEGER                            :: i,j
    3383. 

  3383.     INTEGER                            :: k,kk
    3384. 

  3384.     REAL                               :: desired_press
    3385. 

  3385.     REAL                               :: dlnvaldlnp,dlnp
    3386. 

  3386. 

  3387. 

  3388.       DO K=1,generic
    3389. 

  3389.       DO j = JTS, min(JTE,JDE-1)
    3390. 

  3390.       DO i = ITS, min(ITE,IDE-1)
    3391. 

  3391.         DATA_IN(I,J,K)=max(DATA_in(I,J,K),1.e-13)
    3392. 

  3392.       ENDDO
    3393. 

  3393.       ENDDO
    3394. 

  3394.       ENDDO
    3395. 

  3395. 

  3396.       DO K=KMS,KME
    3397. 

  3397.       DO J=JMS,JME
    3398. 

  3398.       DO I=IMS,IME
    3399. 

  3399.         DATA_OUT(I,J,K)=-99999.9
    3400. 

  3400.       ENDDO
    3401. 

  3401.       ENDDO
    3402. 

  3402.       ENDDO
    3403. 

  3403. 

  3404.     IF (ignore_lowest) then
    3405. 

  3405.        LMIN=2
    3406. 

  3406.     ELSE
    3407. 

  3407.        LMIN=1
    3408. 

  3408.     ENDIF
    3409. 

  3409. 

  3410.     DO j = JTS, min(JTE,JDE-1)
    3411. 

  3411.      test_i:  DO i = ITS, min(ITE,IDE-1)
    3412. 

  3412. 

  3413.       IF (internal_time .gt. 1) THEN
    3414. 

  3414.         IF (J .ne. JDS .and. J .ne. JDE-1 .and. &
    3415. 

  3415.             I .ne. IDS .and. I .ne. IDE-1 ) THEN
    3416. 

  3416. !! not on boundary
    3417. 

  3417.           CYCLE test_i
    3418. 

  3418.         ENDIF
    3419. 

  3419.       ENDIF
    3420. 

  3420. 

  3421. 

  3422.         output_loop: DO k = KDS,KDE-1
    3423. 

  3423. 

  3424.           desired_press = press_out(i,j,k)
    3425. 

  3425. 

  3426.           IF (desired_press .GT. press_in(i,j,LMIN)) THEN
    3427. 

  3427. 

  3428.             IF ((desired_press - press_in(i,j,LMIN)).LT. 10.) THEN ! 0.1 mb
    3429. 

  3429.                data_out(i,j,k) = data_in(i,j,LMIN)
    3430. 

  3430.             ELSE
    3431. 

  3431.               IF (extrapolate) THEN
    3432. 

  3432.                 ! Extrapolate downward because desired P level is below
    3433. 

  3433.                 ! the lowest level in our input data.  Extrapolate using simple
    3434. 

  3434.                 ! 1st derivative of value with respect to ln P for the bottom 2
    3435. 

  3435.                 ! input layers.
    3436. 

  3436. 

  3437.                 ! Add a check to make sure we are not using the gradient of
    3438. 

  3438.                 ! a very thin layer
    3439. 

  3439. 

  3440.                 IF ( (press_in(i,j,LMIN)-press_in(i,j,LMIN+1)) .GT. 100.) THEN
    3441. 

  3441.                   dlnp     = log(press_in(i,j,LMIN))-log(press_in(i,j,LMIN+1))
    3442. 

  3442.                   dlnvaldlnp = ( log(data_in(i,j,LMIN)) - log(data_in(i,j,LMIN+1)) ) / dlnp
    3443. 

  3443. 

  3444.                 ELSE
    3445. 

  3445. 

  3446.                   dlnp     = log(press_in(i,j,LMIN))-log(press_in(i,j,LMIN+2))
    3447. 

  3447.                   dlnvaldlnp = (log(data_in(i,j,LMIN)) - log(data_in(i,j,LMIN+2))) / dlnp
    3448. 

  3448. 

  3449.                 ENDIF
    3450. 

  3450. 

  3451.                 data_out(i,j,k) = exp(log(data_in(i,j,LMIN)) + dlnvaldlnp * &
    3452. 

  3452.                                ( log(desired_press)-log(press_in(i,j,LMIN))))
    3453. 

  3453.               ELSE
    3454. 

  3454.                 data_out(i,j,k) = data_in(i,j,LMIN)
    3455. 

  3455.               ENDIF
    3456. 

  3456.             ENDIF
    3457. 

  3457.           ELSE IF (desired_press .LT. press_in(i,j,generic)) THEN
    3458. 

  3458.             IF ( (press_in(i,j,generic) - desired_press) .LT. 10.) THEN
    3459. 

  3459.                data_out(i,j,k) = data_in(i,j,generic)
    3460. 

  3460.             ELSE
    3461. 

  3461.               IF (extrapolate) THEN
    3462. 

  3462.                 ! Extrapolate upward
    3463. 

  3463.                 IF ((press_in(i,j,generic-1)-press_in(i,j,generic)).GT.50.) THEN
    3464. 

  3464.                   dlnp    =log(press_in(i,j,generic))-log(press_in(i,j,generic-1))
    3465. 

  3465.                   dlnvaldlnp=(log(data_in(i,j,generic))-log(data_in(i,j,generic-1)))/dlnp
    3466. 

  3466.                 ELSE
    3467. 

  3467.                   dlnp    =log(press_in(i,j,generic))-log(press_in(i,j,generic-2))
    3468. 

  3468.                   dlnvaldlnp=(log(data_in(i,j,generic))-log(data_in(i,j,generic-2)))/dlnp
    3469. 

  3469.                 ENDIF
    3470. 

  3470.                 data_out(i,j,k) =  exp(log(data_in(i,j,generic)) + &
    3471. 

  3471.                           dlnvaldlnp * (log(desired_press)-log(press_in(i,j,generic))))
    3472. 

  3472.               ELSE
    3473. 

  3473.                 data_out(i,j,k) = data_in(i,j,generic)
    3474. 

  3474.               ENDIF
    3475. 

  3475.             ENDIF
    3476. 

  3476.           ELSE
    3477. 

  3477.             ! We can trap between two levels and linearly interpolate
    3478. 

  3478. 

  3479.             input_loop:  DO kk = LMIN, generic-1
    3480. 

  3480.               IF (desired_press .EQ. press_in(i,j,kk) )THEN
    3481. 

  3481.                 data_out(i,j,k) = data_in(i,j,kk)
    3482. 

  3482.                 EXIT input_loop
    3483. 

  3483.               ELSE IF ( (desired_press .LT. press_in(i,j,kk)) .AND. &
    3484. 

  3484.                         (desired_press .GT. press_in(i,j,kk+1)) ) THEN
    3485. 

  3485. 

  3486. !       do trapped in lnp
    3487. 

  3487. 

  3488.          dlnp = log(press_in(i,j,kk)) - log(press_in(i,j,kk+1))
    3489. 

  3489.          dlnvaldlnp = (log(data_in(i,j,kk))-log(data_in(i,j,kk+1)))/dlnp
    3490. 

  3490.          data_out(i,j,k) = exp(log(data_in(i,j,kk+1))+ &
    3491. 

  3491.                           dlnvaldlnp*(log(desired_press)-log(press_in(i,j,kk+1))))
    3492. 

  3492. 

  3493.                 EXIT input_loop
    3494. 

  3494. 

  3495.               ENDIF
    3496. 

  3496. 

  3497.             ENDDO input_loop
    3498. 

  3498.           ENDIF
    3499. 

  3499.         ENDDO output_loop
    3500. 

  3500.       ENDDO test_i
    3501. 

  3501.     ENDDO
    3502. 

  3502.   END SUBROUTINE interp_press2press_log
    3503. 

  3503. 

  3504. !-------------------------------------------------------------------
    3505. 

  3505.    SUBROUTINE rh_to_mxrat (rh, t, p, q , wrt_liquid , &
    3506. 

  3506.                            ids , ide , jds , jde , kds , kde , &
    3507. 

  3507.                            ims , ime , jms , jme , kms , kme , &
    3508. 

  3508.                            its , ite , jts , jte , kts , kte )
    3509. 

  3509. 

  3510.       IMPLICIT NONE
    3511. 

  3511. 

  3512.       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
    3513. 

  3513.                                      ims , ime , jms , jme , kms , kme , &
    3514. 

  3514.                                      its , ite , jts , jte , kts , kte
    3515. 

  3515. 

  3516.       LOGICAL , INTENT(IN)        :: wrt_liquid
    3517. 

  3517. 

  3518. !      REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN)     :: p , t
    3519. 

  3519. !      REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT)  :: rh
    3520. 

  3520.       REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(IN)     :: p , t
    3521. 

  3521.       REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(INOUT)  :: rh
    3522. 

  3522.       REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(OUT)    :: q
    3523. 

  3523. 

  3524.       !  Local vars
    3525. 

  3525. 

  3526.       INTEGER                     :: i , j , k
    3527. 

  3527. 

  3528.       REAL                        :: ew , q1 , t1
    3529. 

  3529. 

  3530.       REAL,         PARAMETER     :: T_REF       = 0.0
    3531. 

  3531.       REAL,         PARAMETER     :: MW_AIR      = 28.966
    3532. 

  3532.       REAL,         PARAMETER     :: MW_VAP      = 18.0152
    3533. 

  3533. 

  3534.       REAL,         PARAMETER     :: A0       = 6.107799961
    3535. 

  3535.       REAL,         PARAMETER     :: A1       = 4.436518521e-01
    3536. 

  3536.       REAL,         PARAMETER     :: A2       = 1.428945805e-02
    3537. 

  3537.       REAL,         PARAMETER     :: A3       = 2.650648471e-04
    3538. 

  3538.       REAL,         PARAMETER     :: A4       = 3.031240396e-06
    3539. 

  3539.       REAL,         PARAMETER     :: A5       = 2.034080948e-08
    3540. 

  3540.       REAL,         PARAMETER     :: A6       = 6.136820929e-11
    3541. 

  3541. 

  3542.       REAL,         PARAMETER     :: ES0 = 6.1121
    3543. 

  3543. 

  3544.       REAL,         PARAMETER     :: C1       = 9.09718
    3545. 

  3545.       REAL,         PARAMETER     :: C2       = 3.56654
    3546. 

  3546.       REAL,         PARAMETER     :: C3       = 0.876793
    3547. 

  3547.       REAL,         PARAMETER     :: EIS      = 6.1071
    3548. 

  3548.       REAL                        :: RHS
    3549. 

  3549.       REAL,         PARAMETER     :: TF       = 273.16
    3550. 

  3550.       REAL                        :: TK
    3551. 

  3551. 

  3552.       REAL                        :: ES
    3553. 

  3553.       REAL                        :: QS
    3554. 

  3554.       REAL,         PARAMETER     :: EPS         = 0.622
    3555. 

  3555.       REAL,         PARAMETER     :: SVP1        = 0.6112
    3556. 

  3556.       REAL,         PARAMETER     :: SVP2        = 17.67
    3557. 

  3557.       REAL,         PARAMETER     :: SVP3        = 29.65
    3558. 

  3558.       REAL,         PARAMETER     :: SVPT0       = 273.15
    3559. 

  3559. 

  3560.       !  This subroutine computes mixing ratio (q, kg/kg) from basic variables
    3561. 

  3561.       !  pressure (p, Pa), temperature (t, K) and relative humidity (rh, 1-100%).
    3562. 

  3562.       !  The reference temperature (t_ref, C) is used to describe the temperature
    3563. 

  3563.       !  at which the liquid and ice phase change occurs.
    3564. 

  3564. 

  3565.          DO k = kts , kte
    3566. 

  3566.       DO j = jts , MIN ( jde-1 , jte )
    3567. 

  3567.             DO i = its , MIN (ide-1 , ite )
    3568. 

  3568.                   rh(i,j,k) = MIN ( MAX ( rh(i,j,k) ,  1. ) , 100. )
    3569. 

  3569.             END DO
    3570. 

  3570.          END DO
    3571. 

  3571.       END DO
    3572. 

  3572. 

  3573.       IF ( wrt_liquid ) THEN
    3574. 

  3574.             DO k = kts , kte
    3575. 

  3575.          DO j = jts , MIN ( jde-1 , jte )
    3576. 

  3576.                DO i = its , MIN (ide-1 , ite )
    3577. 

  3577.                   es=svp1*10.*EXP(svp2*(t(i,j,k)-svpt0)/(t(i,j,k)-svp3))
    3578. 

  3578.                   qs=eps*es/(p(i,j,k)/100.-es)
    3579. 

  3579.                   q(i,j,k)=MAX(.01*rh(i,j,k)*qs,0.0)
    3580. 

  3580.                END DO
    3581. 

  3581.             END DO
    3582. 

  3582.          END DO
    3583. 

  3583. 

  3584.       ELSE
    3585. 

  3585.             DO k = kts , kte
    3586. 

  3586.          DO j = jts , MIN ( jde-1 , jte )
    3587. 

  3587.                DO i = its , MIN (ide-1 , ite )
    3588. 

  3588. 

  3589.                   t1 = t(i,j,k) - 273.16
    3590. 

  3590. 

  3591.                   !  Obviously dry.
    3592. 

  3592. 

  3593.                   IF ( t1 .lt. -200. ) THEN
    3594. 

  3594.                      q(i,j,k) = 0
    3595. 

  3595. 

  3596.                   ELSE
    3597. 

  3597. 

  3598.                      !  First compute the ambient vapor pressure of water
    3599. 

  3599. 

  3600.                      IF ( ( t1 .GE. t_ref ) .AND. ( t1 .GE. -47.) ) THEN    ! liq phase ESLO
    3601. 

  3601.                         ew = a0 + t1 * (a1 + t1 * (a2 + t1 * (a3 + t1 * (a4 + t1 * (a5 + t1 * a6)))))
    3602. 

  3602. 

  3603.                      ELSE IF ( ( t1 .GE. t_ref ) .AND. ( t1 .LT. -47. ) ) then !liq phas poor ES
    3604. 

  3604.                         ew = es0 * exp(17.67 * t1 / ( t1 + 243.5))
    3605. 

  3605. 

  3606.                      ELSE
    3607. 

  3607.                         tk = t(i,j,k)
    3608. 

  3608.                         rhs = -c1 * (tf / tk - 1.) - c2 * alog10(tf / tk) +  &
    3609. 

  3609.                                c3 * (1. - tk / tf) +      alog10(eis)
    3610. 

  3610.                         ew = 10. ** rhs
    3611. 

  3611. 

  3612.                      END IF
    3613. 

  3613. 

  3614.                      !  Now sat vap pres obtained compute local vapor pressure
    3615. 

  3615. 

  3616.                      ew = MAX ( ew , 0. ) * rh(i,j,k) * 0.01
    3617. 

  3617. 

  3618.                      !  Now compute the specific humidity using the partial vapor
    3619. 

  3619.                      !  pressures of water vapor (ew) and dry air (p-ew).  The
    3620. 

  3620.                      !  constants assume that the pressure is in hPa, so we divide
    3621. 

  3621.                      !  the pressures by 100.
    3622. 

  3622. 

  3623.                      q1 = mw_vap * ew
    3624. 

  3624.                      q1 = q1 / (q1 + mw_air * (p(i,j,k)/100. - ew))
    3625. 

  3625. 

  3626.                      q(i,j,k) = q1 / (1. - q1 )
    3627. 

  3627. 

  3628.                   END IF
    3629. 

  3629. 

  3630.                END DO
    3631. 

  3631.             END DO
    3632. 

  3632.          END DO
    3633. 

  3633. 

  3634.       END IF
    3635. 

  3635. 

  3636.    END SUBROUTINE rh_to_mxrat
    3637. 

  3637. 

  3638. !--=------------------------------------------------------------------
    3639. 

  3639. 

  3640.       SUBROUTINE  boundary_smooth(h, landmask, grid, nsmth , nrow &
    3641. 

  3641.      &,                          IDS,IDE,JDS,JDE,KDS,KDE             &
    3642. 

  3642.      &,                          IMS,IME,JMS,JME,KMS,KME             &
    3643. 

  3643.      &,                          ITS,ITE,JTS,JTE,KTS,KTE )
    3644. 

  3644. 

  3645. 	implicit none
    3646. 

  3646. 

  3647.       TYPE (domain)          :: grid
    3648. 

  3648. 

  3649.         integer :: IDS,IDE,JDS,JDE,KDS,KDE
    3650. 

  3650.         integer :: IMS,IME,JMS,JME,KMS,KME
    3651. 

  3651.         integer :: ITS,ITE,JTS,JTE,KTS,KTE
    3652. 

  3652.         integer:: ihw(JDS:JDE-1),ihe(JDS:JDE-1),nsmth,nrow
    3653. 

  3653.         real::    h(IMS:IME,JMS:JME),landmask(IMS:IME,JMS:JME)
    3654. 

  3654.         real ::   h_old(IMS:IME,JMS:JME)
    3655. 

  3655.         real ::   hbms(IDS:IDE-1,JDS:JDE-1)
    3656. 

  3656.         real ::   hse(IDS:IDE-1,JDS:JDE-1)
    3657. 

  3657.         real ::   hne(IDS:IDE-1,JDS:JDE-1)
    3658. 

  3658.         integer :: IPS,IPE,JPS,JPE,KPS,KPE
    3659. 

  3659.         integer :: ihl, ihh, m2l, ibas,jmelin
    3660. 

  3660.         integer :: I,J,KS,IOFFSET,JSTART,JEND
    3661. 

  3661.         character (len=255) :: message
    3662. 

  3662. 

  3663. 	ips=its
    3664. 

  3664.         ipe=ite
    3665. 

  3665. 	jps=jts
    3666. 

  3666.         jpe=jte
    3667. 

  3667. 	kps=kts
    3668. 

  3668.         kpe=kte
    3669. 

  3669. 

  3670.         do j= JTS,min(JTE,JDE-1)
    3671. 

  3671.          ihw(J)=-mod(J,2)
    3672. 

  3672.          ihe(j)=ihw(J)+1
    3673. 

  3673.         end do
    3674. 

  3674. 

  3675.         do J=JTS,min(JTE,JDE-1)
    3676. 

  3676.          do I=ITS,min(ITE,IDE-1)
    3677. 

  3677.            hbms(I,J)=landmask(I,J)
    3678. 

  3678.          enddo
    3679. 

  3679.         enddo
    3680. 

  3680. 

  3681.         jmelin=(JDE-1)-nrow+1
    3682. 

  3682.         ibas=nrow/2
    3683. 

  3683.         m2l=mod(nrow,2)
    3684. 

  3684. 

  3685.         do j=jts,min(jte,jde-1)
    3686. 

  3686.          ihl=ibas+mod(j,2)+m2l*mod(J+1,2)
    3687. 

  3687.          ihh=(IDE-1)-ibas-m2l*mod(J+1,2)
    3688. 

  3688.          do i=its,min(ite,ide-1)
    3689. 

  3689.           if (I .ge. ihl .and. I .le. ihh .and. J .ge. nrow .and. J .le. jmelin) then
    3690. 

  3690.            hbms(I,J)=0.
    3691. 

  3691.           endif
    3692. 

  3692.          end do
    3693. 

  3693.         end do
    3694. 

  3694. 

  3695.   634	format(30(f2.0,1x))
    3696. 

  3696. 

  3697.         do KS=1,nsmth
    3698. 

  3698. 

  3699.          grid%ht_gc=h
    3700. 

  3700. #ifdef DM_PARALLEL
    3701. 

  3701. # include "HALO_NMM_MG.inc"
    3702. 

  3702. #endif
    3703. 

  3703.          h=grid%ht_gc
    3704. 

  3704.          h_old=grid%ht_gc
    3705. 

  3705. 

  3706.           do J=JTS,min(JTE,JDE-1)
    3707. 

  3707.            do I=ITS, min(ITE,IDE-1)
    3708. 

  3708.               if (I .ge. (IDS+mod(J,2)) .and. J .gt. JDS .and. J .lt. JDE-1 .and. I .lt. IDE-1) then
    3709. 

  3709.                 h(i,j)= ( h_old(i+ihe(j),j+1) + h_old(i+ihw(j),j-1) + h_old(i+ihe(j),j-1) + h_old(i+ihw(j),j+1) - &
    3710. 

  3710.                         4. *h_old(i,j) )*hbms(i,j)*0.125+h_old(i,j)
    3711. 

  3711.               endif
    3712. 

  3712. 

  3713.            enddo
    3714. 

  3714.           enddo
    3715. 

  3715. 

  3716. !       special treatment for four corners
    3717. 

  3717. 

  3718.         if (hbms(1,1) .eq. 1 .and. ITS .le. 1 .and. JTS .le. 1) then
    3719. 

  3719.         h(1,1)=0.75*h(1,1)+0.125*h(1+ihe(1),2)+  &
    3720. 

  3720.                                  0.0625*(h(2,1)+h(1,3))
    3721. 

  3721.         endif
    3722. 

  3722. 

  3723.         if (hbms(IDE-1,1) .eq. 1 .and. ITE .ge. IDE-2 .and. JTS .le. 1) then
    3724. 

  3724.         h(IDE-1,1)=0.75*h(IDE-1,1)+0.125*h(IDE-1+ihw(1),2)+ &
    3725. 

  3725.                                  0.0625*(h(IDE-1-1,1)+h(IDE-1,3))
    3726. 

  3726.         endif
    3727. 

  3727. 

  3728.         if (hbms(1,JDE-1) .eq. 1 .and. ITS .le. 1 .and. JTE .ge. JDE-2) then
    3729. 

  3729.         h(1,JDE-1)=0.75*h(1,JDE-1)+0.125*h(1+ihe(JDE-1),JDE-1-1)+ &
    3730. 

  3730.                                  0.0625*(h(2,JDE-1)+h(1,JDE-1-2))
    3731. 

  3731.         endif
    3732. 

  3732. 

  3733.         if (hbms(IDE-1,JDE-1) .eq. 1 .and. ITE .ge. IDE-2 .and. JTE .ge. JDE-2) then
    3734. 

  3734.         h(IDE-1,JDE-1)=0.75*h(IDE-1,JDE-1)+0.125*h(IDE-1+ihw(JDE-1),JDE-1-1)+ &
    3735. 

  3735.                                  0.0625*(h(IDE-1-1,JDE-1)+h(IDE-1,JDE-1-2))
    3736. 

  3736.         endif
    3737. 

  3737. 

  3738.         do J=JMS,JME
    3739. 

  3739.          do I=IMS,IME
    3740. 

  3740.          grid%ht_gc(I,J)=h(I,J)
    3741. 

  3741.          enddo
    3742. 

  3742.         enddo
    3743. 

  3743. #ifdef DM_PARALLEL
    3744. 

  3744. # include "HALO_NMM_MG.inc"
    3745. 

  3745. #endif
    3746. 

  3746.          do J=JMS,JME
    3747. 

  3747.          do I=IMS,IME
    3748. 

  3748.          h(I,J)=grid%ht_gc(I,J)
    3749. 

  3749.          enddo
    3750. 

  3750.         enddo
    3751. 

  3751. 

  3752. 

  3753. !       S bound
    3754. 

  3754. 	if (JTS .eq. JDS) then
    3755. 

  3755.         J=JTS
    3756. 

  3756. 

  3757.         do I=ITS,ITE
    3758. 

  3758.         if (I .ge. IDS+1 .and. I .le. IDE-2) then
    3759. 

  3759.         if (hbms(I,J) .eq. 1) then
    3760. 

  3760.         h(I,J)=0.75*h(I,J)+0.125*(h(I+ihw(J),J+1)+h(I+ihe(J),J+1))
    3761. 

  3761.         endif
    3762. 

  3762.         endif
    3763. 

  3763.         enddo
    3764. 

  3764. 

  3765.         endif
    3766. 

  3766. 

  3767. !       N bound
    3768. 

  3768.         if (JTE .eq. JDE) then
    3769. 

  3769.         J=JDE-1
    3770. 

  3770. 	write(message,*) 'DOING N BOUND SMOOTHING for J= ', J
    3771. 

  3771.         CALL wrf_debug(100,message)
    3772. 

  3772.          do I=ITS,min(ITE,IDE-1)
    3773. 

  3773.           if (hbms(I,J) .eq. 1 .and. I .ge. IDS+1 .and. I .le. IDE-2) then
    3774. 

  3774.            h(I,J)=0.75*h(I,J)+0.125*(h(I+ihw(J),J-1)+h(I+ihe(J),J-1))
    3775. 

  3775.           endif
    3776. 

  3776.          enddo
    3777. 

  3777. 	endif
    3778. 

  3778. 

  3779. !       W bound
    3780. 

  3780.         if (ITS .eq. IDS) then
    3781. 

  3781.          I=ITS
    3782. 

  3782.          do J=JTS,min(JTE,JDE-1)
    3783. 

  3783.           if (hbms(I,J) .eq. 1 .and. J .ge. JDS+2 .and. J .le. JDE-3 .and. mod(J,2) .eq. 1) then
    3784. 

  3784.            h(I,J)=0.75*h(I,J)+0.125*(h(I+ihe(J),J+1)+h(I+ihe(J),J-1))
    3785. 

  3785.           endif
    3786. 

  3786.          enddo
    3787. 

  3787. 	endif
    3788. 

  3788. 

  3789. !       E bound
    3790. 

  3790. 	if (ITE .eq. IDE) then
    3791. 

  3791. 	write(message,*) 'DOING E BOUND SMOOTHING for I= ', min(ITE,IDE-1)
    3792. 

  3792.         CALL wrf_debug(100,message)
    3793. 

  3793.          I=min(ITE,IDE-1)
    3794. 

  3794.          do J=JTS,min(JTE,JDE-1)
    3795. 

  3795.           if (hbms(I,J) .eq. 1  .and. J .ge. JDS+2 .and. J .le. JDE-3 .and. mod(J,2) .eq. 1) then
    3796. 

  3796.            h(I,J)=0.75*h(I,J)+0.125*(h(I+ihw(J),J+1)+h(I+ihw(J),J-1))
    3797. 

  3797.           endif
    3798. 

  3798.          enddo
    3799. 

  3799. 	endif
    3800. 

  3800. 

  3801.         enddo   ! end ks loop
    3802. 

  3802. 

  3803.         do J=JMS,JME
    3804. 

  3804.          do I=IMS,IME
    3805. 

  3805.          grid%ht_gc(I,J)=h(I,J)
    3806. 

  3806.          enddo
    3807. 

  3807.         enddo
    3808. 

  3808. #ifdef DM_PARALLEL
    3809. 

  3809. #include "HALO_NMM_MG.inc"
    3810. 

  3810. #endif
    3811. 

  3811.         do J=JMS,JME
    3812. 

  3812.          do I=IMS,IME
    3813. 

  3813.          h(I,J)=grid%ht_gc(I,J)
    3814. 

  3814.         enddo
    3815. 

  3815.         enddo
    3816. 

  3816. 

  3817. ! extra smoothing along inner boundary
    3818. 

  3818. 

  3819.           if (JTS .eq. JDS) then
    3820. 

  3820.            if (ITE .eq. IDE) then
    3821. 

  3821.               IOFFSET=1
    3822. 

  3822.            else
    3823. 

  3823.               IOFFSET=0
    3824. 

  3824.            endif
    3825. 

  3825. !  Southern Boundary
    3826. 

  3826.            do i=its,min(ITE,IDE-1)-IOFFSET
    3827. 

  3827.              h(i,2)=0.25*(h(i,1)+h(i+1,1)+ &
    3828. 

  3828.                           h(i,3)+h(i+1,3))
    3829. 

  3829.            enddo
    3830. 

  3830.           endif
    3831. 

  3831. 

  3832. 

  3833.           if (JTE .eq. JDE) then
    3834. 

  3834.            if (ITE .eq. IDE) then
    3835. 

  3835.               IOFFSET=1
    3836. 

  3836.            else
    3837. 

  3837.               IOFFSET=0
    3838. 

  3838.            endif
    3839. 

  3839.            do i=its,min(ITE,IDE-1)-IOFFSET
    3840. 

  3840.              h(i,(JDE-1)-1)=0.25*(h(i,(JDE-1)-2)+h(i+1,(JDE-1)-2)+ &
    3841. 

  3841.                                 h(i,JDE-1)+h(i+1,JDE-1))
    3842. 

  3842.            enddo
    3843. 

  3843.           endif
    3844. 

  3844. 

  3845.            if (JTS .eq. 1) then
    3846. 

  3846.              JSTART=4
    3847. 

  3847.            else
    3848. 

  3848.              JSTART=JTS+mod(JTS,2) ! needs to be even
    3849. 

  3849.            endif
    3850. 

  3850. 

  3851.            if (JTE .eq. JDE) then
    3852. 

  3852.              JEND=(JDE-1)-3
    3853. 

  3853.            else
    3854. 

  3854.              JEND=JTE
    3855. 

  3855.            endif
    3856. 

  3856. 

  3857.           if (ITS .eq. IDS) then
    3858. 

  3858. 

  3859. !  Western Boundary
    3860. 

  3860.           do j=JSTART,JEND,2
    3861. 

  3861.             h(1,j)=0.25*(h(1,j-1)+h(2,j-1)+ &
    3862. 

  3862.                          h(1,j+1)+h(2,j+1))
    3863. 

  3863. 

  3864.           enddo
    3865. 

  3865.           endif
    3866. 

  3866. 	
    3867. 

  3867. 

  3868.           if (ITE .eq. IDE) then
    3869. 

  3869. !  Eastern Boundary
    3870. 

  3870.           do j=JSTART,JEND,2
    3871. 

  3871.             h((IDE-1)-1,j)=0.25*(h((IDE-1)-1,j-1)+h((IDE-1),j-1)+        &
    3872. 

  3872.                                  h((IDE-1)-1,j+1)+h((IDE-1),j+1))
    3873. 

  3873.           enddo
    3874. 

  3874.           endif
    3875. 

  3875. 

  3876. 

  3877.        END SUBROUTINE boundary_smooth
    3878. 

  3878. 

  3879. !--------------------------------------------------------------------
    3880. 

  3880. 

  3881.    SUBROUTINE monthly_interp_to_date ( field_in , date_str , field_out , &
    3882. 

  3882.                       ids , ide , jds , jde , kds , kde , &
    3883. 

  3883.                       ims , ime , jms , jme , kms , kme , &
    3884. 

  3884.                       its , ite , jts , jte , kts , kte )
    3885. 

  3885. 

  3886.    !  Linrarly in time interpolate data to a current valid time.  The data is
    3887. 

  3887.    !  assumed to come in "monthly", valid at the 15th of every month.
    3888. 

  3888. 

  3889.       IMPLICIT NONE
    3890. 

  3890. 

  3891.       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
    3892. 

  3892.                                      ims , ime , jms , jme , kms , kme , &
    3893. 

  3893.                                      its , ite , jts , jte , kts , kte
    3894. 

  3894. 

  3895.       CHARACTER (LEN=24) , INTENT(IN) :: date_str
    3896. 

  3896.       REAL , DIMENSION(ims:ime,jms:jme,12) , INTENT(IN)  :: field_in
    3897. 

  3897.       REAL , DIMENSION(ims:ime,   jms:jme) , INTENT(OUT) :: field_out
    3898. 

  3898. 

  3899.       !  Local vars
    3900. 

  3900. 

  3901.       INTEGER :: i , j , l
    3902. 

  3902.       INTEGER , DIMENSION(0:13) :: middle
    3903. 

  3903.       INTEGER :: target_julyr , target_julday , target_date
    3904. 

  3904.       INTEGER :: julyr , julday , int_month, next_month
    3905. 

  3905.       REAL :: gmt
    3906. 

  3906.       CHARACTER (LEN=4) :: yr
    3907. 

  3907.       CHARACTER (LEN=2) :: mon , day15
    3908. 

  3908. 

  3909. 

  3910.       WRITE(day15,FMT='(I2.2)') 15
    3911. 

  3911.       DO l = 1 , 12
    3912. 

  3912.          WRITE(mon,FMT='(I2.2)') l
    3913. 

  3913.          CALL get_julgmt ( date_str(1:4)//'-'//mon//'-'//day15//'_'//'00:00:00.0000' , julyr , julday , gmt )
    3914. 

  3914.          middle(l) = julyr*1000 + julday
    3915. 

  3915.       END DO
    3916. 

  3916. 

  3917.       l = 0
    3918. 

  3918.       middle(l) = middle( 1) - 31
    3919. 

  3919. 

  3920.       l = 13
    3921. 

  3921.       middle(l) = middle(12) + 31
    3922. 

  3922. 

  3923.       CALL get_julgmt ( date_str , target_julyr , target_julday , gmt )
    3924. 

  3924.       target_date = target_julyr * 1000 + target_julday
    3925. 

  3925.       find_month : DO l = 0 , 12
    3926. 

  3926.          IF ( ( middle(l) .LT. target_date ) .AND. ( middle(l+1) .GE. target_date ) ) THEN
    3927. 

  3927.             DO j = jts , MIN ( jde-1 , jte )
    3928. 

  3928.                DO i = its , MIN (ide-1 , ite )
    3929. 

  3929.                   int_month = MOD ( l , 12 )
    3930. 

  3930.                   IF ( int_month .EQ. 0 ) int_month = 12
    3931. 

  3931. 

  3932. 	IF (int_month == 12) THEN
    3933. 

  3933.             next_month=1
    3934. 

  3934.         ELSE
    3935. 

  3935.             next_month=int_month+1
    3936. 

  3936.         ENDIF
    3937. 

  3937. 

  3938.                   field_out(i,j) =  ( field_in(i,j,next_month) * ( target_date - middle(l)   ) + &
    3939. 

  3939.                                       field_in(i,j,int_month  ) * ( middle(l+1) - target_date ) ) / &
    3940. 

  3940.                                     ( middle(l+1) - middle(l) )
    3941. 

  3941.                END DO
    3942. 

  3942.             END DO
    3943. 

  3943.             EXIT find_month
    3944. 

  3944.          END IF
    3945. 

  3945.       END DO find_month
    3946. 

  3946.    END SUBROUTINE monthly_interp_to_date
    3947. 

  3947. 

  3948. !---------------------------------------------------------------------
    3949. 

  3949.    SUBROUTINE monthly_min_max ( field_in , field_min , field_max , &
    3950. 

  3950.                       ids , ide , jds , jde , kds , kde , &
    3951. 

  3951.                       ims , ime , jms , jme , kms , kme , &
    3952. 

  3952.                       its , ite , jts , jte , kts , kte )
    3953. 

  3953. 

  3954.    !  Plow through each month, find the max, min values for each i,j.
    3955. 

  3955. 

  3956.       IMPLICIT NONE
    3957. 

  3957. 

  3958.       INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
    3959. 

  3959.                                      ims , ime , jms , jme , kms , kme , &
    3960. 

  3960.                                      its , ite , jts , jte , kts , kte
    3961. 

  3961. 

  3962.       REAL , DIMENSION(ims:ime,jms:jme,12) , INTENT(IN)  :: field_in
    3963. 

  3963.       REAL , DIMENSION(ims:ime,   jms:jme) , INTENT(OUT) :: field_min , field_max
    3964. 

  3964. 

  3965.       !  Local vars
    3966. 

  3966. 

  3967.       INTEGER :: i , j , l
    3968. 

  3968.       REAL :: minner , maxxer
    3969. 

  3969. 

  3970.       DO j = jts , MIN(jde-1,jte)
    3971. 

  3971.          DO i = its , MIN(ide-1,ite)
    3972. 

  3972.             minner = field_in(i,j,1)
    3973. 

  3973.             maxxer = field_in(i,j,1)
    3974. 

  3974.             DO l = 2 , 12
    3975. 

  3975.                IF ( field_in(i,j,l) .LT. minner ) THEN
    3976. 

  3976.                   minner = field_in(i,j,l)
    3977. 

  3977.                END IF
    3978. 

  3978.                IF ( field_in(i,j,l) .GT. maxxer ) THEN
    3979. 

  3979.                   maxxer = field_in(i,j,l)
    3980. 

  3980.                END IF
    3981. 

  3981.             END DO
    3982. 

  3982.             field_min(i,j) = minner
    3983. 

  3983.             field_max(i,j) = maxxer
    3984. 

  3984.          END DO
    3985. 

  3985.       END DO
    3986. 

  3986. 

  3987.    END SUBROUTINE monthly_min_max
    3988. 

  3988. 

  3989. !-----------------------------------------------------------------------
    3990. 

  3990. 

  3991.   SUBROUTINE reverse_vert_coord  ( field, start_z, end_z                &
    3992. 

  3992.      &,                             IDS,IDE,JDS,JDE,KDS,KDE             &
    3993. 

  3993.      &,                             IMS,IME,JMS,JME,KMS,KME             &
    3994. 

  3994.      &,                             ITS,ITE,JTS,JTE,KTS,KTE )
    3995. 

  3995. 

  3996. 	IMPLICIT NONE
    3997. 

  3997. 

  3998.         INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
    3999. 

  3999.                                        ims , ime , jms , jme , kms , kme , &
    4000. 

  4000.                                        its , ite , jts , jte , kts , kte,  &
    4001. 

  4001.                                        start_z, end_z
    4002. 

  4002. 

  4003.         REAL, INTENT(INOUT)         :: field(IMS:IME,JMS:JME,end_z)
    4004. 

  4004. ! local
    4005. 

  4005. 

  4006.         INTEGER                     :: I,J,L
    4007. 

  4007.         REAL, ALLOCATABLE           :: dum3d(:,:,:)
    4008. 

  4008. 

  4009.         allocate(dum3d(IMS:IME,JMS:JME,end_z))
    4010. 

  4010. 

  4011.         DO L=start_z,end_z
    4012. 

  4012.           DO J=jts,min(jte,jde-1)
    4013. 

  4013.             DO I=its,min(ite,ide-1)
    4014. 

  4014. 	      dum3d(I,J,L)=field(I,J,end_z-L+start_z)
    4015. 

  4015.             END DO
    4016. 

  4016.           END DO
    4017. 

  4017.         END DO
    4018. 

  4018. 

  4019.         DO L=start_z,end_z
    4020. 

  4020.           DO J=jts,min(jte,jde-1)
    4021. 

  4021.             DO I=its,min(ite,ide-1)
    4022. 

  4022.               field(I,J,L)=dum3d(I,J,L)
    4023. 

  4023.             END DO
    4024. 

  4024.           END DO
    4025. 

  4025.         END DO
    4026. 

  4026. 

  4027.         DEALLOCATE(dum3d)
    4028. 

  4028. 

  4029.         END SUBROUTINE reverse_vert_coord
    4030. 

  4030. 

  4031. 

  4032. !--------------------------------------------------------------------
    4033. 

  4033. 

  4034.         SUBROUTINE compute_nmm_levels(ninterface, ptop, eta_levels)
    4035. 

  4035. 

  4036.         USE module_model_constants
    4037. 

  4037. 

  4038.         IMPLICIT NONE
    4039. 

  4039. 

  4040.         character(len=132):: message
    4041. 

  4041.         integer        ::  ninterface,Lthick,L
    4042. 

  4042.         real, parameter:: gamma=.0065
    4043. 

  4043.         real, parameter:: t_stand=288.
    4044. 

  4044.         real, parameter:: p_stand=101325.
    4045. 

  4045. 

  4046.         real           ::  maxdz_compute, ptop
    4047. 

  4047.         real           ::  plower,pupper,tlay, sum
    4048. 

  4048. 

  4049.         real             :: eta_levels(ninterface)
    4050. 

  4050.         real, allocatable:: Z(:)
    4051. 

  4051.         real, allocatable:: deta_levels_spline(:)
    4052. 

  4052. 

  4053.         logical:: print_pbl_warn
    4054. 

  4054. 

  4055. !----------------------------------------------------
    4056. 

  4056. 

  4057.         allocate(Z(ninterface))
    4058. 

  4058.         allocate(deta_levels_spline(ninterface-1))
    4059. 

  4059. 

  4060.         CALL compute_eta_spline(ninterface-1,deta_levels_spline,ptop)
    4061. 

  4061. 

  4062.         sum=0.
    4063. 

  4063.         DO L=1,ninterface-1
    4064. 

  4064.           sum=sum+deta_levels_spline(L)
    4065. 

  4065.         ENDDO
    4066. 

  4066. 

  4067.         eta_levels(1)=1.00
    4068. 

  4068. 

  4069.         DO L=2,ninterface
    4070. 

  4070.           eta_levels(L)=eta_levels(L-1)-deta_levels_spline(L-1)
    4071. 

  4071.         ENDDO
    4072. 

  4072. 

  4073.         eta_levels(ninterface)=0.00
    4074. 

  4074. 

  4075.         DO L=2,ninterface-1
    4076. 

  4076.           eta_levels(L)=0.5*(eta_levels(L))+0.25*(eta_levels(L-1)+eta_levels(L+1))
    4077. 

  4077.         ENDDO
    4078. 

  4078. 

  4079.         Z(1)=0.
    4080. 

  4080.         maxdz_compute=0.
    4081. 

  4081.         print_pbl_warn=.false.
    4082. 

  4082. 

  4083.         DO L=2,ninterface
    4084. 

  4084.           tlay=max( t_stand-gamma*Z(L-1), 216.5)
    4085. 

  4085.           plower=ptop+(p_stand-ptop)*eta_levels(L-1)
    4086. 

  4086.           pupper=ptop+(p_stand-ptop)*eta_levels(L)
    4087. 

  4087.           Z(L)=Z(L-1)+(tlay*r_d/g)*(log(plower)-log(pupper))
    4088. 

  4088. 

  4089.           if (plower .gt. 85000. .and. pupper .lt. 85000. .and. L .lt. 10) then
    4090. 

  4090.             print_pbl_warn=.true.
    4091. 

  4091.           endif
    4092. 

  4092. 

  4093.           write(message,*) 'L, eta(l), pupper, Z(L): ', L, eta_levels(L),pupper,Z(L)
    4094. 

  4094.           CALL wrf_debug(100,message)
    4095. 

  4095. 

  4096.           if (Z(L)-Z(L-1) .gt. maxdz_compute) then
    4097. 

  4097.             Lthick=L
    4098. 

  4098.           endif
    4099. 

  4099. 

  4100.           maxdz_compute=max(maxdz_compute,Z(L)-Z(L-1))
    4101. 

  4101.         ENDDO
    4102. 

  4102. 

  4103.         if (print_pbl_warn) then
    4104. 

  4104.           write(message,*) 'WARNING - PBL MAY BE POORLY RESOLVED WITH NUMBER OF VERTICAL LEVELS'
    4105. 

  4105.           CALL wrf_message(message)
    4106. 

  4106.           write(message,*) '        - CONSIDER INCREASING THE VERTICAL RESOLUTION'
    4107. 

  4107.           CALL wrf_message(message)
    4108. 

  4108.         endif
    4109. 

  4109. 

  4110.         write(message,*) 'thickest layer was: ', maxdz_compute , 'meters thick at level: ', Lthick
    4111. 

  4111.         CALL wrf_message(message)
    4112. 

  4112. 

  4113.         END SUBROUTINE compute_nmm_levels
    4114. 

  4114. 

  4115. !---------------------------
    4116. 

  4116. 

  4117.      SUBROUTINE compute_eta_spline(LM, dsg, ptop)
    4118. 

  4118. 

  4119.      IMPLICIT NONE
    4120. 

  4120. 

  4121.      real:: dsg(LM), ptop, sum, rsum
    4122. 

  4122.      real, allocatable:: xold(:),dold(:)
    4123. 

  4123.      real, allocatable:: xnew(:),sgm(:)
    4124. 

  4124.      real, allocatable:: pps(:),qqs(:),y2s(:)
    4125. 

  4125.      integer nlev,LM,L,KOLD
    4126. 

  4126. 

  4127.     IF (LM .ge. 46) THEN
    4128. 

  4128.      KOLD=9
    4129. 

  4129.      allocate(xold(KOLD))
    4130. 

  4130.      allocate(dold(KOLD))
    4131. 

  4131. 

  4132.      xold(1)=.00
    4133. 

  4133.      dold(1)=.006
    4134. 

  4134.      xold(2)=.13
    4135. 

  4135.      dold(2)=.009
    4136. 

  4136.      xold(3)=.19
    4137. 

  4137.      dold(3)=.012
    4138. 

  4138.      xold(4)=.30
    4139. 

  4139.      dold(4)=.036
    4140. 

  4140.      xold(5)=.42
    4141. 

  4141.      dold(5)=.041
    4142. 

  4142.      xold(6)=.56
    4143. 

  4143.      dold(6)=.040
    4144. 

  4144.      xold(7)=.69
    4145. 

  4145.      dold(7)=.018
    4146. 

  4146. 

  4147.      if (ptop .ge. 2000.) then
    4148. 

  4148.       xold(8)=.90
    4149. 

  4149.       dold(8)=.012
    4150. 

  4150.       xold(9)=1.0
    4151. 

  4151.       dold(9)=.006
    4152. 

  4152.      else
    4153. 

  4153.       xold(8)=.90
    4154. 

  4154.       dold(8)=.008
    4155. 

  4155.       xold(9)=1.0
    4156. 

  4156.       dold(9)=.003
    4157. 

  4157.      endif
    4158. 

  4158. 

  4159.     ELSE
    4160. 

  4160. 

  4161.      KOLD=8
    4162. 

  4162.      allocate(xold(KOLD))
    4163. 

  4163.      allocate(dold(KOLD))
    4164. 

  4164. 

  4165.      xold(1)=.00
    4166. 

  4166.      dold(1)=.006
    4167. 

  4167.      xold(2)=.18
    4168. 

  4168.      dold(2)=.015
    4169. 

  4169.      xold(3)=.32
    4170. 

  4170.      dold(3)=.035
    4171. 

  4171.      xold(4)=.50
    4172. 

  4172.      dold(4)=.040
    4173. 

  4173.      xold(5)=.68
    4174. 

  4174.      dold(5)=.030
    4175. 

  4175.      xold(6)=.75
    4176. 

  4176.      dold(6)=.017
    4177. 

  4177.      xold(7)=.85
    4178. 

  4178.      dold(7)=.012
    4179. 

  4179. 

  4180.      if (ptop .ge. 2000.) then
    4181. 

  4181.       xold(8)=1.0
    4182. 

  4182.       dold(8)=.013
    4183. 

  4183.      else
    4184. 

  4184.       xold(8)=1.0
    4185. 

  4185.       dold(8)=.008
    4186. 

  4186.      endif
    4187. 

  4187. 

  4188.     ENDIF
    4189. 

  4189. 

  4190.         allocate(xnew(lm))
    4191. 

  4191.         allocate(sgm(lm+1))
    4192. 

  4192.         allocate(pps(lm))
    4193. 

  4193.         allocate(qqs(lm))
    4194. 

  4194.         allocate(y2s(lm))
    4195. 

  4195. 

  4196.     DO L=1,LM
    4197. 

  4197.        xnew(l)=float(l-1)/float(lm-1)
    4198. 

  4198.     ENDDO
    4199. 

  4199. 

  4200.     y2s=0.
    4201. 

  4201. 

  4202.     CALL spline(kold,xold,dold,y2s,lm,xnew,dsg,pps,qqs)
    4203. 

  4203. 

  4204.     sum=0.
    4205. 

  4205.     DO l=1,lm
    4206. 

  4206.        sum=sum+dsg(l)
    4207. 

  4207.     ENDDO
    4208. 

  4208. 

  4209.     rsum=1./sum
    4210. 

  4210.     sgm(1)=0.
    4211. 

  4211. 

  4212.     DO L=1,lm-1
    4213. 

  4213.      dsg(l)=dsg(l)*rsum
    4214. 

  4214.      sgm(l+1)=sgm(l)+dsg(l)
    4215. 

  4215.     ENDDO
    4216. 

  4216.     sgm(lm+1)=1.
    4217. 

  4217.     dsg(lm)=sgm(lm+1)-sgm(lm)
    4218. 

  4218. 

  4219.     END SUBROUTINE compute_eta_spline
    4220. 

  4220. 

  4221. ! -------------------------------------------------------------------
    4222. 

  4222. 

  4223.      subroutine spline(NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,q)
    4224. 

  4224. 

  4225. !   ********************************************************************
    4226. 

  4226. !   *                                                                  *
    4227. 

  4227. !   *  THIS IS A ONE-DIMENSIONAL CUBIC SPLINE FITTING ROUTINE          *
    4228. 

  4228. !   *  PROGRAMED FOR A SMALL SCALAR MACHINE.                           *
    4229. 

  4229. !   *                                                                  *
    4230. 

  4230. !   *  PROGRAMER Z. JANJIC                                             *
    4231. 

  4231. !   *                                                                  *
    4232. 

  4232. !   *  NOLD - NUMBER OF GIVEN VALUES OF THE FUNCTION.  MUST BE GE 3.   *
    4233. 

  4233. !   *  XOLD - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE       *
    4234. 

  4234. !   *         FUNCTION ARE GIVEN.  MUST BE IN ASCENDING ORDER.         *
    4235. 

  4235. !   *  YOLD - THE GIVEN VALUES OF THE FUNCTION AT THE POINTS XOLD.     *
    4236. 

  4236. !   *  Y2   - THE SECOND DERIVATIVES AT THE POINTS XOLD.  IF NATURAL   *
    4237. 

  4237. !   *         SPLINE IS FITTED Y2(1)=0. AND Y2(NOLD)=0. MUST BE        *
    4238. 

  4238. !   *         SPECIFIED.                                               *
    4239. 

  4239. !   *  NNEW - NUMBER OF VALUES OF THE FUNCTION TO BE CALCULATED.       *
    4240. 

  4240. !   *  XNEW - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE       *
    4241. 

  4241. !   *         FUNCTION ARE CALCULATED.  XNEW(K) MUST BE GE XOLD(1)     *
    4242. 

  4242. !   *         AND LE XOLD(NOLD).                                       *
    4243. 

  4243. !   *  YNEW - THE VALUES OF THE FUNCTION TO BE CALCULATED.             *
    4244. 

  4244. !   *  P, q - AUXILIARY VECTORS OF THE LENGTH NOLD-2.                  *
    4245. 

  4245. !   *                                                                  *
    4246. 

  4246. !   ********************************************************************
    4247. 

  4247. !
    4248. 

  4248. !   LOG:
    4249. 

  4249. !
    4250. 

  4250. !     JOVIC - July 2008 - fixed incorrectly dimensioned arrays,
    4251. 

  4251. !     PYLE                and do loop leading to out of bound array
    4252. 

  4252. !                         reference
    4253. 

  4253. !------
    4254. 

  4254. !
    4255. 

  4255. !     PYLE - June 2007 - eliminated use of GO TO statements.
    4256. 

  4256. !
    4257. 

  4257. !-----------------------------------------------------------------------
    4258. 

  4258.       IMPLICIT NONE
    4259. 

  4259. !-----------------------------------------------------------------------
    4260. 

  4260.       INTEGER,INTENT(IN) :: NNEW,NOLD
    4261. 

  4261.       REAL,DIMENSION(NOLD),INTENT(IN) :: XOLD,YOLD
    4262. 

  4262.       REAL,DIMENSION(NNEW),INTENT(IN)  :: XNEW
    4263. 

  4263.       REAL,DIMENSION(NNEW),INTENT(OUT) :: YNEW
    4264. 

  4264.       REAL,DIMENSION(NOLD+2),INTENT(INOUT) :: P,q,Y2
    4265. 

  4265. !
    4266. 

  4266.       INTEGER :: K,K1,K2,KOLD,NOLDM1, K2_hold, K_hold
    4267. 

  4267.       REAL :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR                   &
    4268. 

  4268.      &       ,RDX,RTDXC,X,XK,XSQ,Y2K,Y2KP1
    4269. 

  4269. !-----------------------------------------------------------------------
    4270. 

  4270. 

  4271.       NOLDM1=NOLD-1
    4272. 

  4272. 

  4273.       DXL=XOLD(2)-XOLD(1)
    4274. 

  4274.       DXR=XOLD(3)-XOLD(2)
    4275. 

  4275.       DYDXL=(YOLD(2)-YOLD(1))/DXL
    4276. 

  4276.       DYDXR=(YOLD(3)-YOLD(2))/DXR
    4277. 

  4277.       RTDXC=0.5/(DXL+DXR)
    4278. 

  4278. 

  4279.       P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1))
    4280. 

  4280.       q(1)=-RTDXC*DXR
    4281. 

  4281. 

  4282.       K=3
    4283. 

  4283.       first_loop: DO K=3,NOLD-1
    4284. 

  4284.         DXL=DXR
    4285. 

  4285.         DYDXL=DYDXR
    4286. 

  4286.         DXR=XOLD(K+1)-XOLD(K)
    4287. 

  4287.         DYDXR=(YOLD(K+1)-YOLD(K))/DXR
    4288. 

  4288.         DXC=DXL+DXR
    4289. 

  4289.         DEN=1./(DXL*q(K-2)+DXC+DXC)
    4290. 

  4290.         P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2))
    4291. 

  4291.         q(K-1)=-DEN*DXR
    4292. 

  4292.       END DO first_loop
    4293. 

  4293. 

  4294.       DO K=NOLDM1,2,-1
    4295. 

  4295.          Y2(K)=P(K-1)+q(K-1)*Y2(K+1)
    4296. 

  4296.          K_hold=K
    4297. 

  4297.       END DO
    4298. 

  4298. 

  4299.       K=K_hold
    4300. 

  4300. 

  4301. !-----------------------------------------------------------------------
    4302. 

  4302.       second_loop:  DO K1=1,NNEW
    4303. 

  4303.         XK=XNEW(K1)
    4304. 

  4304.         third_loop:  DO K2=2,NOLD
    4305. 

  4305. 

  4306.           IF(XOLD(K2)>XK)THEN
    4307. 

  4307.             KOLD=K2-1
    4308. 

  4308.             K2_hold=K2
    4309. 

  4309.             exit third_loop
    4310. 

  4310.           ENDIF
    4311. 

  4311.         K2_hold=K2
    4312. 

  4312.         END DO third_loop
    4313. 

  4313. 

  4314.         IF (XOLD(K2_hold) .le. XK) THEN
    4315. 

  4315.           YNEW(K1)=YOLD(NOLD)
    4316. 

  4316.           CYCLE second_loop
    4317. 

  4317.         ENDIF
    4318. 

  4318. 

  4319.         IF (K1 .eq. 1 .or. K .ne. KOLD) THEN
    4320. 

  4320.           K=KOLD
    4321. 

  4321.           Y2K=Y2(K)
    4322. 

  4322.           Y2KP1=Y2(K+1)
    4323. 

  4323.           DX=XOLD(K+1)-XOLD(K)
    4324. 

  4324.           RDX=1./DX
    4325. 

  4325.           AK=.1666667*RDX*(Y2KP1-Y2K)
    4326. 

  4326.           BK=0.5*Y2K
    4327. 

  4327.           CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K)
    4328. 

  4328.         ENDIF
    4329. 

  4329. 

  4330.         X=XK-XOLD(K)
    4331. 

  4331.         XSQ=X*X
    4332. 

  4332.         YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K)
    4333. 

  4333. 

  4334.       END DO second_loop
    4335. 

  4335. 

  4336.       END SUBROUTINE SPLINE
    4337. 

  4337. !--------------------------------------------------------------------
    4338. 

  4338.       SUBROUTINE NMM_SH2O(IMS,IME,JMS,JME,ISTART,IM,JSTART,JM,&
    4339. 

  4339.                         NSOIL,ISLTPK, &
    4340. 

  4340.                         sm,sice,stc,smc,sh2o)
    4341. 

  4341. 

  4342. !!        INTEGER, PARAMETER:: NSOTYP=9
    4343. 

  4343. !        INTEGER, PARAMETER:: NSOTYP=16
    4344. 

  4344.         INTEGER, PARAMETER:: NSOTYP=19 !!!!!!!!MAYBE???
    4345. 

  4345. 

  4346.         REAL :: PSIS(NSOTYP),BETA(NSOTYP),SMCMAX(NSOTYP)
    4347. 

  4347.         REAL :: stc(IMS:IME,NSOIL,JMS:JME), &
    4348. 

  4348.                 smc(IMS:IME,NSOIL,JMS:JME)
    4349. 

  4349.         REAL :: sh2o(IMS:IME,NSOIL,JMS:JME),sice(IMS:IME,JMS:JME),&
    4350. 

  4350.                 sm(IMS:IME,JMS:JME)
    4351. 

  4351.         REAL :: HLICE,GRAV,T0,BLIM
    4352. 

  4352.         INTEGER :: ISLTPK(IMS:IME,JMS:JME)
    4353. 

  4353.         CHARACTER(LEN=255) :: message
    4354. 

  4354. 

  4355. ! Constants used in cold start sh2o initialization
    4356. 

  4356.       DATA HLICE/3.335E5/,GRAV/9.81/,T0/273.15/
    4357. 

  4357.       DATA BLIM/5.5/
    4358. 

  4358. !      DATA PSIS /0.04,0.62,0.47,0.14,0.10,0.26,0.14,0.36,0.04/
    4359. 

  4359. !      DATA BETA /4.26,8.72,11.55,4.74,10.73,8.17,6.77,5.25,4.26/
    4360. 

  4360. !      DATA SMCMAX /0.421,0.464,0.468,0.434,0.406, &
    4361. 

  4361. !                  0.465,0.404,0.439,0.421/
    4362. 

  4362. 

  4363. 

  4364. !!!      NOT SURE...PSIS=SATPSI, BETA=BB??
    4365. 

  4365. 

  4366.         DATA PSIS /0.069, 0.036, 0.141, 0.759, 0.759, 0.355,   &
    4367. 

  4367.                    0.135, 0.617, 0.263, 0.098, 0.324, 0.468,   &
    4368. 

  4368.                    0.355, 0.000, 0.069, 0.036, 0.468, 0.069, 0.069  /
    4369. 

  4369. 

  4370.         DATA BETA/2.79,  4.26,  4.74,  5.33,  5.33,  5.25,    &
    4371. 

  4371.                   6.66,  8.72,  8.17, 10.73, 10.39, 11.55,    &
    4372. 

  4372.                   5.25,  0.00,  2.79,  4.26, 11.55, 2.79, 2.79 /
    4373. 

  4373. 

  4374.         DATA SMCMAX/0.339, 0.421, 0.434, 0.476, 0.476, 0.439,  &
    4375. 

  4375.                     0.404, 0.464, 0.465, 0.406, 0.468, 0.468,  &
    4376. 

  4376.                     0.439, 1.000, 0.200, 0.421, 0.468, 0.200, 0.339/
    4377. 

  4377. 

  4378.         DO K=1,NSOIL
    4379. 

  4379.          DO J=JSTART,JM
    4380. 

  4380.           DO I=ISTART,IM
    4381. 

  4381. 

  4382. !tst
    4383. 

  4383.         IF (smc(I,K,J) .gt. SMCMAX(ISLTPK(I,J))) then
    4384. 

  4384.   if (K .eq. 1) then
    4385. 

  4385.     write(message,*) 'I,J,reducing smc from ' ,I,J,smc(I,K,J), 'to ', SMCMAX(ISLTPK(I,J))
    4386. 

  4386.     CALL wrf_debug(100,message)
    4387. 

  4387.   endif
    4388. 

  4388.         smc(I,K,J)=SMCMAX(ISLTPK(I,J))
    4389. 

  4389.         ENDIF
    4390. 

  4390. !tst
    4391. 

  4391. 

  4392.         IF ( (sm(I,J) .lt. 0.5) .and. (sice(I,J) .lt. 0.5) ) THEN
    4393. 

  4393. 

  4394.         IF (ISLTPK(I,J) .gt. 19) THEN
    4395. 

  4395.                 WRITE(message,*) 'FORCING ISLTPK at : ', I,J
    4396. 

  4396.                 CALL wrf_message(message)
    4397. 

  4397.                 ISLTPK(I,J)=9
    4398. 

  4398.         ELSEIF (ISLTPK(I,J) .le. 0) then
    4399. 

  4399.                 WRITE(message,*) 'FORCING ISLTPK at : ', I,J
    4400. 

  4400.                 CALL wrf_message(message)
    4401. 

  4401.                 ISLTPK(I,J)=1
    4402. 

  4402.         ENDIF
    4403. 

  4403. 

  4404. 

  4405. ! cold start:  determine liquid soil water content (sh2o)
    4406. 

  4406. ! sh2o <= smc for t < 273.149K (-0.001C)
    4407. 

  4407. 

  4408.            IF (stc(I,K,J) .LT. 273.149) THEN
    4409. 

  4409. 

  4410. ! first guess following explicit solution for Flerchinger Eqn from Koren
    4411. 

  4411. ! et al, JGR, 1999, Eqn 17 (KCOUNT=0 in FUNCTION FRH2O).
    4412. 

  4412. 

  4413.               BX = BETA(ISLTPK(I,J))
    4414. 

  4414.               IF ( BETA(ISLTPK(I,J)) .GT. BLIM ) BX = BLIM
    4415. 

  4415. 

  4416.         if ( GRAV*(-PSIS(ISLTPK(I,J))) .eq. 0 ) then
    4417. 

  4417.         write(message,*) 'TROUBLE'
    4418. 

  4418.         CALL wrf_message(message)
    4419. 

  4419.         write(message,*) 'I,J: ', i,J
    4420. 

  4420.         CALL wrf_message(message)
    4421. 

  4421.         write(message,*) 'grav, isltpk, psis(isltpk): ', grav,isltpk(I,J),&
    4422. 

  4422.                  psis(isltpk(I,J))
    4423. 

  4423.         CALL wrf_message(message)
    4424. 

  4424.         endif
    4425. 

  4425. 

  4426.         if (BX .eq. 0 .or. stc(I,K,J) .eq. 0) then
    4427. 

  4427.                 write(message,*) 'TROUBLE -- I,J,BX, stc: ', I,J,BX,stc(I,K,J)
    4428. 

  4428.                 CALL wrf_message(message)
    4429. 

  4429.         endif
    4430. 

  4430.               FK = (((HLICE/(GRAV*(-PSIS(ISLTPK(I,J)))))* &
    4431. 

  4431.                   ((stc(I,K,J)-T0)/stc(I,K,J)))** &
    4432. 

  4432.                   (-1/BX))*SMCMAX(ISLTPK(I,J))
    4433. 

  4433.               IF (FK .LT. 0.02) FK = 0.02
    4434. 

  4434.               sh2o(I,K,J) = MIN ( FK, smc(I,K,J) )
    4435. 

  4435. ! ----------------------------------------------------------------------
    4436. 

  4436. ! now use iterative solution for liquid soil water content using
    4437. 

  4437. ! FUNCTION FRH2O (from the Eta "NOAH" land-surface model) with the
    4438. 

  4438. ! initial guess for sh2o from above explicit first guess.
    4439. 

  4439. 

  4440.               sh2o(I,K,J)=FRH2O_init(stc(I,K,J),smc(I,K,J),sh2o(I,K,J), &
    4441. 

  4441.                          SMCMAX(ISLTPK(I,J)),BETA(ISLTPK(I,J)), &
    4442. 

  4442.                          PSIS(ISLTPK(I,J)))
    4443. 

  4443. 

  4444.             ELSE ! above freezing
    4445. 

  4445.               sh2o(I,K,J)=smc(I,K,J)
    4446. 

  4446.             ENDIF
    4447. 

  4447. 

  4448. 

  4449.         ELSE   ! water point
    4450. 

  4450.               sh2o(I,K,J)=smc(I,K,J)
    4451. 

  4451. 

  4452.         ENDIF ! test on land/ice/sea
    4453. 

  4453.         if (sh2o(I,K,J) .gt. SMCMAX(ISLTPK(I,J))) then
    4454. 

  4454.           write(message,*) 'sh2o > THAN SMCMAX ', I,J,sh2o(I,K,J),SMCMAX(ISLTPK(I,J)),smc(I,K,J)
    4455. 

  4455.           CALL wrf_message(message)
    4456. 

  4456.         endif
    4457. 

  4457. 

  4458.          ENDDO
    4459. 

  4459.         ENDDO
    4460. 

  4460.        ENDDO
    4461. 

  4461. 

  4462.         END SUBROUTINE NMM_SH2O
    4463. 

  4463. 

  4464. !-------------------------------------------------------------------
    4465. 

  4465. 

  4466.       FUNCTION FRH2O_init(TKELV,smc,sh2o,SMCMAX,B,PSIS)
    4467. 

  4467. 

  4468.       IMPLICIT NONE
    4469. 

  4469. 

  4470. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4471. 

  4471. !  PURPOSE:  CALCULATE AMOUNT OF SUPERCOOLED LIQUID SOIL WATER CONTENT
    4472. 

  4472. !  IF TEMPERATURE IS BELOW 273.15K (T0).  REQUIRES NEWTON-TYPE ITERATION
    4473. 

  4473. !  TO SOLVE THE NONLINEAR IMPLICIT EQUATION GIVEN IN EQN 17 OF
    4474. 

  4474. !  KOREN ET AL. (1999, JGR, VOL 104(D16), 19569-19585).
    4475. 

  4475. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4476. 

  4476. !
    4477. 

  4477. ! New version (JUNE 2001): much faster and more accurate newton iteration
    4478. 

  4478. ! achieved by first taking log of eqn cited above -- less than 4
    4479. 

  4479. ! (typically 1 or 2) iterations achieves convergence.  Also, explicit
    4480. 

  4480. ! 1-step solution option for special case of parameter Ck=0, which reduces
    4481. 

  4481. ! the original implicit equation to a simpler explicit form, known as the
    4482. 

  4482. ! ""Flerchinger Eqn". Improved handling of solution in the limit of
    4483. 

  4483. ! freezing point temperature T0.
    4484. 

  4484. !
    4485. 

  4485. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4486. 

  4486. !
    4487. 

  4487. ! INPUT:
    4488. 

  4488. !
    4489. 

  4489. !   TKELV.........Temperature (Kelvin)
    4490. 

  4490. !   smc...........Total soil moisture content (volumetric)
    4491. 

  4491. !   sh2o..........Liquid soil moisture content (volumetric)
    4492. 

  4492. !   SMCMAX........Saturation soil moisture content (from REDPRM)
    4493. 

  4493. !   B.............Soil type "B" parameter (from REDPRM)
    4494. 

  4494. !   PSIS..........Saturated soil matric potential (from REDPRM)
    4495. 

  4495. !
    4496. 

  4496. ! OUTPUT:
    4497. 

  4497. !   FRH2O.........supercooled liquid water content.
    4498. 

  4498. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4499. 

  4499. 

  4500.       REAL B
    4501. 

  4501.       REAL BLIM
    4502. 

  4502.       REAL BX
    4503. 

  4503.       REAL CK
    4504. 

  4504.       REAL DENOM
    4505. 

  4505.       REAL DF
    4506. 

  4506.       REAL DH2O
    4507. 

  4507.       REAL DICE
    4508. 

  4508.       REAL DSWL
    4509. 

  4509.       REAL ERROR
    4510. 

  4510.       REAL FK
    4511. 

  4511.       REAL FRH2O_init
    4512. 

  4512.       REAL GS
    4513. 

  4513.       REAL HLICE
    4514. 

  4514.       REAL PSIS
    4515. 

  4515.       REAL sh2o
    4516. 

  4516.       REAL smc
    4517. 

  4517.       REAL SMCMAX
    4518. 

  4518.       REAL SWL
    4519. 

  4519.       REAL SWLK
    4520. 

  4520.       REAL TKELV
    4521. 

  4521.       REAL T0
    4522. 

  4522. 

  4523.       INTEGER NLOG
    4524. 

  4524.       INTEGER KCOUNT
    4525. 

  4525.       PARAMETER (CK=8.0)
    4526. 

  4526. !      PARAMETER (CK=0.0)
    4527. 

  4527.       PARAMETER (BLIM=5.5)
    4528. 

  4528. !      PARAMETER (BLIM=7.0)
    4529. 

  4529.       PARAMETER (ERROR=0.005)
    4530. 

  4530. 

  4531.       PARAMETER (HLICE=3.335E5)
    4532. 

  4532.       PARAMETER (GS = 9.81)
    4533. 

  4533.       PARAMETER (DICE=920.0)
    4534. 

  4534.       PARAMETER (DH2O=1000.0)
    4535. 

  4535.       PARAMETER (T0=273.15)
    4536. 

  4536. 

  4537. !  ###   LIMITS ON PARAMETER B: B < 5.5  (use parameter BLIM)  ####
    4538. 

  4538. !  ###   SIMULATIONS SHOWED IF B > 5.5 UNFROZEN WATER CONTENT  ####
    4539. 

  4539. !  ###   IS NON-REALISTICALLY HIGH AT VERY LOW TEMPERATURES    ####
    4540. 

  4540. !  ################################################################
    4541. 

  4541. !
    4542. 

  4542.       BX = B
    4543. 

  4543.       IF ( B .GT. BLIM ) BX = BLIM
    4544. 

  4544. ! ------------------------------------------------------------------
    4545. 

  4545. 

  4546. ! INITIALIZING ITERATIONS COUNTER AND ITERATIVE SOLUTION FLAG.
    4547. 

  4547.       NLOG=0
    4548. 

  4548.       KCOUNT=0
    4549. 

  4549. 

  4550. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4551. 

  4551. ! C  IF TEMPERATURE NOT SIGNIFICANTLY BELOW FREEZING (T0), sh2o = smc
    4552. 

  4552. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4553. 

  4553. 

  4554. 

  4555.       IF (TKELV .GT. (T0 - 1.E-3)) THEN
    4556. 

  4556. 

  4557.         FRH2O_init=smc
    4558. 

  4558. 

  4559.       ELSE
    4560. 

  4560. 

  4561. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4562. 

  4562.        IF (CK .NE. 0.0) THEN
    4563. 

  4563. 

  4564. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4565. 

  4565. ! CCCCCCCCC OPTION 1: ITERATED SOLUTION FOR NONZERO CK CCCCCCCCCCC
    4566. 

  4566. ! CCCCCCCCCCCC IN KOREN ET AL, JGR, 1999, EQN 17 CCCCCCCCCCCCCCCCC
    4567. 

  4567. 

  4568. ! INITIAL GUESS FOR SWL (frozen content)
    4569. 

  4569.         SWL = smc-sh2o
    4570. 

  4570. ! KEEP WITHIN BOUNDS.
    4571. 

  4571.          IF (SWL .GT. (smc-0.02)) SWL=smc-0.02
    4572. 

  4572.          IF(SWL .LT. 0.) SWL=0.
    4573. 

  4573. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4574. 

  4574. ! C  START OF ITERATIONS
    4575. 

  4575. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4576. 

  4576.         DO WHILE (NLOG .LT. 10 .AND. KCOUNT .EQ. 0)
    4577. 

  4577.          NLOG = NLOG+1
    4578. 

  4578.          DF = ALOG(( PSIS*GS/HLICE ) * ( ( 1.+CK*SWL )**2. ) * &
    4579. 

  4579.              ( SMCMAX/(smc-SWL) )**BX) - ALOG(-(TKELV-T0)/TKELV)
    4580. 

  4580.          DENOM = 2. * CK / ( 1.+CK*SWL ) + BX / ( smc - SWL )
    4581. 

  4581.          SWLK = SWL - DF/DENOM
    4582. 

  4582. ! BOUNDS USEFUL FOR MATHEMATICAL SOLUTION.
    4583. 

  4583.          IF (SWLK .GT. (smc-0.02)) SWLK = smc - 0.02
    4584. 

  4584.          IF(SWLK .LT. 0.) SWLK = 0.
    4585. 

  4585. ! MATHEMATICAL SOLUTION BOUNDS APPLIED.
    4586. 

  4586.          DSWL=ABS(SWLK-SWL)
    4587. 

  4587.          SWL=SWLK
    4588. 

  4588. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4589. 

  4589. ! CC IF MORE THAN 10 ITERATIONS, USE EXPLICIT METHOD (CK=0 APPROX.)
    4590. 

  4590. ! CC WHEN DSWL LESS OR EQ. ERROR, NO MORE ITERATIONS REQUIRED.
    4591. 

  4591. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4592. 

  4592.          IF ( DSWL .LE. ERROR )  THEN
    4593. 

  4593.            KCOUNT=KCOUNT+1
    4594. 

  4594.          END IF
    4595. 

  4595.         END DO
    4596. 

  4596. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4597. 

  4597. ! C  END OF ITERATIONS
    4598. 

  4598. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4599. 

  4599. ! BOUNDS APPLIED WITHIN DO-BLOCK ARE VALID FOR PHYSICAL SOLUTION.
    4600. 

  4600.         FRH2O_init = smc - SWL
    4601. 

  4601. 

  4602. ! CCCCCCCCCCCCCCCCCCCCCCCC END OPTION 1 CCCCCCCCCCCCCCCCCCCCCCCCCCC
    4603. 

  4603. 

  4604.        ENDIF
    4605. 

  4605. 

  4606.        IF (KCOUNT .EQ. 0) THEN
    4607. 

  4607. !         Print*,'Flerchinger used in NEW version. Iterations=',NLOG
    4608. 

  4608. 

  4609. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    4610. 

  4610. ! CCCCC OPTION 2: EXPLICIT SOLUTION FOR FLERCHINGER EQ. i.e. CK=0 CCCCCCCC
    4611. 

  4611. ! CCCCCCCCCCCCC IN KOREN ET AL., JGR, 1999, EQN 17  CCCCCCCCCCCCCCC
    4612. 

  4612. 

  4613.         FK=(((HLICE/(GS*(-PSIS)))*((TKELV-T0)/TKELV))**(-1/BX))*SMCMAX
    4614. 

  4614. ! APPLY PHYSICAL BOUNDS TO FLERCHINGER SOLUTION
    4615. 

  4615.         IF (FK .LT. 0.02) FK = 0.02
    4616. 

  4616.         FRH2O_init = MIN ( FK, smc )
    4617. 

  4617. 

  4618. ! CCCCCCCCCCCCCCCCCCCCCCCCC END OPTION 2 CCCCCCCCCCCCCCCCCCCCCCCCCC
    4619. 

  4619. 

  4620.        ENDIF
    4621. 

  4621. 

  4622.       ENDIF
    4623. 

  4623. 

  4624.         RETURN
    4625. 

  4625. 

  4626.       END FUNCTION FRH2O_init
    4627. 

  4627. 

  4628. 

  4629. !--------------------------------------------------------------------
    4630. 

  4630. 

  4631.    SUBROUTINE init_module_initialize
    4632. 

  4632.    END SUBROUTINE init_module_initialize
    4633. 

  4633. 

  4634. !---------------------------------------------------------------------
    4635. 

  4635. !-------------------------------------------------------------------------------
    4636. 

  4636. 

  4637.  SUBROUTINE vortex ( ght_gc,rh_gc,t_gc,u_gc,v_gc,p_gc              &
    4638. 

  4638.      &,              ght_out,rh_out,t_out,u_out,v_out              &
    4639. 

  4639.      &,              ht_gc,tsk_gc,xice_gc                          &
    4640. 

  4640.      &,              hlat_gc,hlon_gc,vlat_gc,vlon_gc               &
    4641. 

  4641.      &,              greenfrac_gc,albedo12m_gc,landusef_gc         &
    4642. 

  4642.      &,              soilctop_gc,soilcbot_gc                       &
    4643. 

  4643.      &,              landusef_out,soilctop_out,soilcbot_out        &
    4644. 

  4644.      &,              num_veg_cat,num_soil_top_cat,num_soil_bot_cat &
    4645. 

  4645.      &,              dx,internal_time_loop                         &
    4646. 

  4646.      &,              start_z,end_z                                 &
    4647. 

  4647.      &,              ids,ide,jds,jde,kds,kde                       &
    4648. 

  4648.      &,              ims,ime,jms,jme,kms,kme                       &
    4649. 

  4649.      &,              its,ite,jts,jte,kts,kte                       )
    4650. 

  4650. 

  4651. 

  4652.  USE module_dm
    4653. 

  4653.  IMPLICIT NONE
    4654. 

  4654. 

  4655.  LOGICAL,EXTERNAL   :: WRF_DM_ON_MONITOR
    4656. 

  4656. 

  4657. INTEGER, INTENT(IN):: ids,ide,jds,jde,kds,kde, &
    4658. 

  4658.                        ims,ime,jms,jme,kms,kme, &
    4659. 

  4659.                        its,ite,jts,jte,kts,kte, &
    4660. 

  4660.                        internal_time_loop
    4661. 

  4661. 

  4662.  INTEGER, INTENT(IN):: num_veg_cat,num_soil_top_cat,num_soil_bot_cat,start_z, end_z
    4663. 

  4663. 

  4664.  REAL, DIMENSION(IMS:IME,JMS:JME,start_z:end_z),INTENT(INOUT)   :: ght_gc,rh_gc,t_gc,u_gc,v_gc,p_gc
    4665. 

  4665.  REAL, DIMENSION(IMS:IME,JMS:JME,start_z:end_z),INTENT(INOUT)   :: ght_out,rh_out,t_out,u_out,v_out
    4666. 

  4666.  REAL, DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT)                 :: ht_gc,tsk_gc,xice_gc
    4667. 

  4667.  REAL, DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT)                 :: hlat_gc,hlon_gc,vlat_gc,vlon_gc
    4668. 

  4668. 

  4669.  REAL, DIMENSION(ims:ime,jms:jme,12) , INTENT(INOUT)            :: greenfrac_gc,albedo12m_gc
    4670. 

  4670.  REAL, DIMENSION(ims:ime,jms:jme,num_veg_cat), INTENT(INOUT)    :: landusef_gc,landusef_out
    4671. 

  4671. 

  4672.  REAL, DIMENSION(ims:ime,jms:jme,num_soil_top_cat),INTENT(INOUT):: soilctop_gc,soilctop_out
    4673. 

  4673.  REAL, DIMENSION(ims:ime,jms:jme,num_soil_bot_cat),INTENT(INOUT):: soilcbot_gc,soilcbot_out
    4674. 

  4674.  REAL,                                             INTENT(INOUT):: dx
    4675. 

  4675. 

  4676.  REAL, PARAMETER                                 :: eradius=6371221.3
    4677. 

  4677.  INTEGER                                         :: i,j,l,iter,nmax,nres,nfilter
    4678. 

  4678.  INTEGER                                         :: id0,jd0,id1,jd1
    4679. 

  4679.  REAL                                            :: factor,glon0,glat0,dist,cavlat,minval_gh
    4680. 

  4680.  REAL                                            :: beta1,vmax,rmax,dx_km
    4681. 

  4681.  REAL,  DIMENSION(start_z:end_z)                 :: vmax1,rmax1
    4682. 

  4682.  REAL,  DIMENSION(IMS:IME,JMS:JME)               :: dist1,dir1,diffx,diffy
    4683. 

  4683.  REAL,  DIMENSION(IMS:IME,JMS:JME,start_z:end_z) :: pert_ght,pert_rh,pert_t,pert_u,pert_v,pert_p,temp0
    4684. 

  4684. !New Vortex Related
    4685. 

  4685.  DATA beta1 /0.0/   ! 0.0 sets non-linear balance equation vortex. GFDL vortex for beta1 between 0.1 and 1.5
    4686. 

  4686. 

  4687.  REAL, ALLOCATABLE,DIMENSION(:,:)   :: psc
    4688. 

  4688.  REAL, ALLOCATABLE,DIMENSION(:,:,:) :: u_temp,v_temp,t_temp,ght_temp,rh_temp
    4689. 

  4689. 

  4690. !----------------------------------------------------------------------------
    4691. 

  4691. !  PURPOSE:
    4692. 

  4692. !         - HURRICANE VORTEX FILTERING
    4693. 

  4693. !         - HURRICANE VORTEX INITIALIZATION
    4694. 

  4694. !
    4695. 

  4695. !         This is gopal's doing
    4696. 

  4696. !----------------------------------------------------------------------------
    4697. 

  4697. 

  4698.  WRITE(0,*)'---------------- IDEAL CASE -------------------------'
    4699. 

  4699.  WRITE(0,*)'number of pressure levels',end_z
    4700. 

  4700.  WRITE(0,*)'number of vegcat   levels',num_veg_cat
    4701. 

  4701.  WRITE(0,*)'number of soiltop  levels',num_soil_top_cat
    4702. 

  4702.  WRITE(0,*)'number of soilbot  levels',num_soil_bot_cat
    4703. 

  4703.  WRITE(0,*)'--------------- ght_gc --------------------------'
    4704. 

  4704.  WRITE(0,*)ght_gc(100,100,:)
    4705. 

  4705.  WRITE(0,*)'--------------- p_gc --------------------------'
    4706. 

  4706.  WRITE(0,*)p_gc(100,100,:)
    4707. 

  4707.  WRITE(0,*)'--------------- rh_gc ---------------------------'
    4708. 

  4708.  WRITE(0,*)rh_gc(100,100,:)
    4709. 

  4709.  WRITE(0,*)'--------------- t_gc --------------------------'
    4710. 

  4710.  WRITE(0,*)t_gc(100,100,:)
    4711. 

  4711.  WRITE(0,*)'------------------------------------------------'
    4712. 

  4712.  WRITE(0,*)'------------------------------------------------'
    4713. 

  4713. 

  4714. !
    4715. 

  4715. !   SET UP IDEAL CONDITIONS
    4716. 

  4716. !
    4717. 

  4717. 

  4718.     do l = 1,num_veg_cat
    4719. 

  4719.      do j = jts, MIN(jte,jde-1)
    4720. 

  4720.       do i = its, MIN(ite,ide-1)
    4721. 

  4721.         if(l==16)THEN
    4722. 

  4722.            landusef_out(i,j,l)=1                    ! create ocean everywhere
    4723. 

  4723.         else
    4724. 

  4724.             landusef_out(i,j,l)=0
    4725. 

  4725.         endif
    4726. 

  4726.       enddo
    4727. 

  4727.      enddo
    4728. 

  4728.     enddo
    4729. 

  4729. 

  4730.     do l = 1,num_soil_top_cat
    4731. 

  4731.      do j = jts, MIN(jte,jde-1)
    4732. 

  4732.       do i = its, MIN(ite,ide-1)
    4733. 

  4733.         if(l==14)THEN
    4734. 

  4734.            soilctop_out(i,j,l)=1                    ! create ocean everywhere
    4735. 

  4735.         else
    4736. 

  4736.            soilctop_out(i,j,l)=0
    4737. 

  4737.         endif
    4738. 

  4738.       enddo
    4739. 

  4739.      enddo
    4740. 

  4740.     enddo
    4741. 

  4741.    do l = 1,num_soil_bot_cat
    4742. 

  4742.      do j = jts, MIN(jte,jde-1)
    4743. 

  4743.       do i = its, MIN(ite,ide-1)
    4744. 

  4744.         if(l==14)THEN
    4745. 

  4745.            soilcbot_out(i,j,l)=1                    ! create ocean everywhere
    4746. 

  4746.         else
    4747. 

  4747.            soilcbot_out(i,j,l)=0
    4748. 

  4748.         endif
    4749. 

  4749.       enddo
    4750. 

  4750.      enddo
    4751. 

  4751.     enddo
    4752. 

  4752. 

  4753. 

  4754.     landusef_gc=landusef_out       !=landusef_gc
    4755. 

  4755.     soilcbot_gc=soilcbot_out       !=soilcbot_gc
    4756. 

  4756.     soilctop_gc=soilctop_out       !=soilctop_gc
    4757. 

  4757. 

  4758. 

  4759.     do j = jts, MIN(jte,jde-1)
    4760. 

  4760.      do i = its, MIN(ite,ide-1)
    4761. 

  4761.       xice_gc(i,j)=0.
    4762. 

  4762.       ht_gc(i,j)=0.                                 ! uniform terrain
    4763. 

  4763.       ght_gc(i,j,1)=0.                              ! uniform gpm at level 1
    4764. 

  4764.       tsk_gc(i,j)=302.0                             ! uniform SSTs
    4765. 

  4765.      enddo
    4766. 

  4766.     enddo
    4767. 

  4767. 

  4768. !
    4769. 

  4769. ! Make sure the GFDL analysis does not have temperature problems especially
    4770. 

  4770. ! near the surface. I noticed some problems with the wps outputs (met_nmm file.)
    4771. 

  4771. !
    4772. 

  4772.     do j=jts,min(jte,jde-1)
    4773. 

  4773.      do i=its,min(ite,ide-1)
    4774. 

  4774.        if(t_gc(i,j,1) .le. 250.0)t_gc(i,j,1)=302.5
    4775. 

  4775.      enddo
    4776. 

  4776.     enddo
    4777. 

  4777. !
    4778. 

  4778. !     READ IN LAT-LONS FROM STORM MESSAGE FILE
    4779. 

  4779. !
    4780. 

  4780.   IF (WRF_DM_ON_MONITOR()) THEN
    4781. 

  4781. !orig   OPEN(21,file='../MESSAGES/storm.center',status='old')
    4782. 

  4782. !repository messages
    4783. 

  4783.    OPEN(21,file='../messages/storm.center',status='old')
    4784. 

  4784.    read(21,*)glat0
    4785. 

  4785.    read(21,*)glon0
    4786. 

  4786.    close(21)
    4787. 

  4787.   ENDIF
    4788. 

  4788. 

  4789.   CALL wrf_dm_bcast_bytes (glat0,IWORDSIZE)
    4790. 

  4790.   CALL wrf_dm_bcast_bytes (glon0,IWORDSIZE)
    4791. 

  4791. 

  4792.   WRITE(0,*)'glat0 and glon0',glat0,glon0
    4793. 

  4793. 

  4794. !
    4795. 

  4795. !
    4796. 

  4796. ! FIND THE CENTER OF THE HURRICANE BASED ON THE STORM MESSAGE FILE
    4797. 

  4797. !
    4798. 

  4798.   id0  = -999
    4799. 

  4799.   jd0  = -999
    4800. 

  4800.   factor = 4.0*ATAN(1.)/180.
    4801. 

  4801.   dist  = -1
    4802. 

  4802.   do j=jts,min(jte,jde-1)
    4803. 

  4803.     do i=its,min(ite,ide-1)
    4804. 

  4804.      diffx(i,j) = (hlon_gc(i,j) - glon0)*factor
    4805. 

  4805.      diffy(i,j) = (hlat_gc(i,j) - glat0)*factor
    4806. 

  4806.      cavlat= cos((hlat_gc(i,j) + glat0)*0.5*factor)
    4807. 

  4807.      dist1(i,j) = eradius*sqrt(cavlat*cavlat*diffx(i,j)*diffx(i,j) + diffy(i,j)*diffy(i,j))
    4808. 

  4808.      if(dist1(i,j).LE.dist .OR. dist.LT.0.)then
    4809. 

  4809.        dist  = dist1(i,j)
    4810. 

  4810.        id0 = i
    4811. 

  4811.        jd0 = j
    4812. 

  4812.      endif
    4813. 

  4813.     enddo
    4814. 

  4814.   enddo
    4815. 

  4815. 

  4816. !
    4817. 

  4817. ! SECONDARY SEARCH FOR THE CENTER
    4818. 

  4818. !
    4819. 

  4819. 

  4820.   id1=-999
    4821. 

  4821.   jd1=-999
    4822. 

  4822.   minval_gh=MINVAL(ght_gc(ids:ide-1,jds:jde-1,10))
    4823. 

  4823.   write(0,*)'MIN VAL OF GH NEW=',minval_gh
    4824. 

  4824.   do j=jts,min(jte,jde-1)
    4825. 

  4825.    do i=its,min(ite,ide-1)
    4826. 

  4826.       if(minval_gh .EQ. ght_gc(i,j,10))then
    4827. 

  4827.        id1=i
    4828. 

  4828.        jd1=j
    4829. 

  4829.       endif
    4830. 

  4830.     enddo
    4831. 

  4831.   enddo
    4832. 

  4832. 

  4833.   IF(abs(ID0-ID1) .GE. 5 .OR. abs(JD0-JD1) .GE. 5)THEN
    4834. 

  4834. !   call wrf_error_fatal("LAT LON INFO IN STROM MESSAGE FILE IN INCORRECT")
    4835. 

  4835.     write(0,*) 'WARNING - ACTUAL STORM LOCATION DIFFERENT FROM MODEL LOCATION'
    4836. 

  4836.     WRITE(0,*)'OLD CENTER',ID0,JD0
    4837. 

  4837.     WRITE(0,*)'NEW CENTER',ID1,JD1
    4838. 

  4838.   ELSE
    4839. 

  4839.     WRITE(0,*)'OLD CENTER',ID0,JD0
    4840. 

  4840.     WRITE(0,*)'NEW CENTER',ID1,JD1
    4841. 

  4841.   ENDIF
    4842. 

  4842. 

  4843. !
    4844. 

  4844. ! RECOMPUTE RADIUS FROM THE CENTER BASED ON MODEL/ANALYSED STORM CENTER
    4845. 

  4845. !
    4846. 

  4846.   do j=jts,min(jte,jde-1)
    4847. 

  4847.     do i=its,min(ite,ide-1)
    4848. 

  4848.      diffx(i,j) = (hlon_gc(i,j) - hlon_gc(id1,jd1))*factor
    4849. 

  4849.      diffy(i,j) = (hlat_gc(i,j) - hlat_gc(id1,jd1))*factor
    4850. 

  4850.      cavlat= cos((hlat_gc(i,j) + hlat_gc(id1,jd1))*0.5*factor)
    4851. 

  4851.      dist1(i,j) = eradius*sqrt(cavlat*cavlat*diffx(i,j)*diffx(i,j) + diffy(i,j)*diffy(i,j))
    4852. 

  4852.    enddo
    4853. 

  4853.   enddo
    4854. 

  4854. 

  4855. 

  4856.  ght_out=ght_gc
    4857. 

  4857.  t_out=t_gc
    4858. 

  4858.  rh_out=rh_gc
    4859. 

  4859.  u_out=u_gc
    4860. 

  4860.  v_out=v_gc
    4861. 

  4861. 

  4862. !
    4863. 

  4863. ! Beta is the intensity parameter
    4864. 

  4864. !
    4865. 

  4865. 

  4866.   IF(BETA1 .NE. 0.)THEN   ! Adjustment of the GFDL vortex
    4867. 

  4867. 

  4868. !
    4869. 

  4869. ! DEFINE THE NUMBER OF RECRUSSIVE OPERATIONS (NMAX) REQUIRED TO
    4870. 

  4870. ! REMOVE OR MODIFY THE INITIAL GRIB ANALYSIS. IF beta1 IS SET TO
    4871. 

  4871. ! < 0.01, THE VORTEX IS COMPLETELY FILTERED OUT. ALSO, FILTERING
    4872. 

  4872. ! RELATED TO COMPLETE VORTEX REMOVAL IS ONLY CALLED AT THE INITIAL
    4873. 

  4873. ! TIME ASSUMING THAT THE VORTEX IS FAR AWAY FROM THE BOUNDARIES.
    4874. 

  4874. !
    4875. 

  4875. 

  4876.     nres=0.18/dx
    4877. 

  4877.     nfilter=1
    4878. 

  4878. !
    4879. 

  4879.     if(nres==3.and. internal_time_loop .eq. 1)then
    4880. 

  4880.       nmax=9*nfilter
    4881. 

  4881.     else
    4882. 

  4882.       nmax=1*nfilter
    4883. 

  4883.     endif
    4884. 

  4884. 

  4885.     WRITE(0,*)'CALLING HBFILTER'
    4886. 

  4886. 

  4887.     CALL hbfilter ( ght_gc,ght_out               &
    4888. 

  4888.         &,          nmax,start_z,end_z           &
    4889. 

  4889.         &,          ids,ide,jds,jde              &
    4890. 

  4890.         &,          ims,ime,jms,jme              &
    4891. 

  4891.         &,          its,ite,jts,jte              )
    4892. 

  4892. 

  4893.     WRITE(0,*)'COMPLETED FILTERING ght_gc'
    4894. 

  4894. 

  4895.     CALL hbfilter ( t_gc,t_out                   &
    4896. 

  4896.         &,          nmax,start_z,end_z           &
    4897. 

  4897.         &,          ids,ide,jds,jde              &
    4898. 

  4898.         &,          ims,ime,jms,jme              &
    4899. 

  4899.         &,          its,ite,jts,jte              )
    4900. 

  4900. 

  4901.     WRITE(0,*)'COMPLETED FILTERING t_gc'
    4902. 

  4902. 

  4903.     CALL hbfilter ( rh_gc,rh_out                 &
    4904. 

  4904.         &,          nmax,start_z,end_z           &
    4905. 

  4905.         &,          ids,ide,jds,jde              &
    4906. 

  4906.         &,          ims,ime,jms,jme              &
    4907. 

  4907.         &,          its,ite,jts,jte              )
    4908. 

  4908. 

  4909.     WRITE(0,*)'COMPLETED FILTERING rh_gc'
    4910. 

  4910. 

  4911.     CALL hbfilter ( u_gc,u_out                   &
    4912. 

  4912.         &,          nmax,start_z,end_z           &
    4913. 

  4913.         &,          ids,ide,jds,jde              &
    4914. 

  4914.         &,          ims,ime,jms,jme              &
    4915. 

  4915.         &,          its,ite,jts,jte              )
    4916. 

  4916. 

  4917.     WRITE(0,*)'COMPLETED FILTERING u_gc'
    4918. 

  4918. 

  4919.     CALL hbfilter ( v_gc,v_out                   &
    4920. 

  4920.         &,          nmax,start_z,end_z           &
    4921. 

  4921.         &,          ids,ide,jds,jde              &
    4922. 

  4922.         &,          ims,ime,jms,jme              &
    4923. 

  4923.         &,          its,ite,jts,jte              )
    4924. 

  4924. 

  4925.     WRITE(0,*)'COMPLETED FILTERING v_gc'
    4926. 

  4926. 

  4927.     WRITE(0,*)'END OF HBFILTER'
    4928. 

  4928. !
    4929. 

  4929.     do l=start_z,end_z
    4930. 

  4930.      do j=jts,min(jte,jde-1)
    4931. 

  4931.       do i=its,min(ite,ide-1)
    4932. 

  4932.          pert_ght(i,j,l) =  (ght_gc(i,j,l) - ght_out(i,j,l))      ! vortex only
    4933. 

  4933.          pert_t(i,j,l)   =  (t_gc(i,j,l)   - t_out(i,j,l))
    4934. 

  4934.          pert_rh(i,j,l)  =  (rh_gc(i,j,l)  - rh_out(i,j,l))
    4935. 

  4935.          pert_u(i,j,l)   =  (u_gc(i,j,l)   - u_out(i,j,l))
    4936. 

  4936.          pert_v(i,j,l)   =  (v_gc(i,j,l)   - v_out(i,j,l))
    4937. 

  4937.       enddo
    4938. 

  4938.      enddo
    4939. 

  4939.     enddo
    4940. 

  4940. !
    4941. 

  4941.     do l=start_z,end_z
    4942. 

  4942.      do j=jts,min(jte,jde-1)
    4943. 

  4943.       do i=its,min(ite,ide-1)
    4944. 

  4944.          ght_gc(i,j,l) = ght_out(i,j,l) +  beta1*pert_ght(i,j,l)     ! vortex only
    4945. 

  4945.          t_gc(i,j,l)   = t_out(i,j,l)   +  beta1*pert_t(i,j,l)
    4946. 

  4946.          rh_gc(i,j,l)  = rh_out(i,j,l)  +  beta1*pert_rh(i,j,l)
    4947. 

  4947.          u_gc(i,j,l)   = u_out(i,j,l)   +  beta1*pert_u(i,j,l)
    4948. 

  4948.          v_gc(i,j,l)   = v_out(i,j,l)   +  beta1*pert_v(i,j,l)
    4949. 

  4949.       enddo
    4950. 

  4950.      enddo
    4951. 

  4951.     enddo
    4952. 

  4952. !
    4953. 

  4953. !    DIAGNOSTICS
    4954. 

  4954. 

  4955.      ght_out=0.;t_out=0.;rh_out=0.;u_out=0.;v_out=0.
    4956. 

  4956.      do l=start_z,end_z
    4957. 

  4957.       do j=jts,min(jte,jde-1)
    4958. 

  4958.         do i=its,min(ite,ide-1)
    4959. 

  4959.          ght_out(i,j,l)= beta1*pert_ght(i,j,l)
    4960. 

  4960.          t_out(i,j,l)  = beta1*pert_t(i,j,l)
    4961. 

  4961.          rh_out(i,j,l) = beta1*pert_rh(i,j,l)
    4962. 

  4962.          u_out(i,j,l)  = beta1*pert_u(i,j,l)
    4963. 

  4963.          v_out(i,j,l)  = beta1*pert_v(i,j,l)
    4964. 

  4964.        enddo
    4965. 

  4965.       enddo
    4966. 

  4966.    enddo
    4967. 

  4967. 

  4968.   ELSE !  Balanced vortex option
    4969. 

  4969. 

  4970. !jwb   IF(internal_time_loop .eq. 1)THEN  ! use balancing only at the initial time
    4971. 

  4971.    IF(internal_time_loop .le. 2)THEN  ! use balancing only at the initial time
    4972. 

  4972. 

  4973. 

  4974. !
    4975. 

  4975. ! INSERT NEW VORTEX USING THE BALANCING ALGORITHM DEVELOPED BY ZHIHUA ZENG &
    4976. 

  4976. ! JIAN-WEN BAO. THIS ALGORITHM IS BASED ON INVERSE BALANCE EQUATION
    4977. 

  4977. !
    4978. 

  4978. 

  4979.       WRITE(0,*)'CALLING TCBOGUS'
    4980. 

  4980. 

  4981.       allocate(u_temp(ide,jde,end_z));allocate(v_temp(ide,jde,end_z))
    4982. 

  4982.       allocate(t_temp(ide,jde,end_z));allocate(ght_temp(ide,jde,end_z))
    4983. 

  4983.       allocate(rh_temp(ide,jde,end_z));allocate(psc(ide,jde))
    4984. 

  4984. 

  4985.       dx_km=110000.0*dx    ! dx in kilometers
    4986. 

  4986. 

  4987.       CALL  tcbogus( u_temp,v_temp,t_temp,ght_temp,rh_temp,psc,  &
    4988. 

  4988.                      dx_km,id1,jd1,                              &
    4989. 

  4989.                      start_z,end_z+1,                            &
    4990. 

  4990.                      ids,ide,jds,jde,                            &
    4991. 

  4991.                      ids,ide,jds,jde,                            &
    4992. 

  4992.                      ids,ide,jds,jde                             )
    4993. 

  4993. 

  4994. !    DIAGNOSTICS AND REVERSAL OF LOOP
    4995. 

  4995. 

  4996.      ght_out=0.;t_out=0.;rh_out=0.;u_out=0.;v_out=0.
    4997. 

  4997.      do l=start_z,end_z
    4998. 

  4998.       do j=jts,min(jte,jde-1)
    4999. 

  4999.         do i=its,min(ite,ide-1)
    5000. 

  5000.          if(l .lt.end_z)ght_out(i,j,l+1)= ght_temp(i,j,end_z-l+1)
    5001. 

  5001.          t_out(i,j,l)  = t_temp(i,j,end_z-l+1)
    5002. 

  5002.          rh_out(i,j,l) = rh_temp(i,j,end_z-l+1)
    5003. 

  5003.          u_out(i,j,l)  = u_temp(i,j,end_z-l+1)
    5004. 

  5004.          v_out(i,j,l)  = v_temp(i,j,end_z-l+1)
    5005. 

  5005.         enddo
    5006. 

  5006.       enddo
    5007. 

  5007.      enddo
    5008. 

  5008. 

  5009.       do l=start_z,end_z
    5010. 

  5010.        do j=jts,min(jte,jde-1)
    5011. 

  5011.         do i=its,min(ite,ide-1)
    5012. 

  5012.          ght_gc(i,j,l) = ght_out(i,j,l)
    5013. 

  5013.          t_gc(i,j,l)   = t_out(i,j,l)
    5014. 

  5014.          rh_gc(i,j,l)  = rh_out(i,j,l)
    5015. 

  5015.          u_gc(i,j,l)   = u_out(i,j,l)
    5016. 

  5016.          v_gc(i,j,l)   = v_out(i,j,l)
    5017. 

  5017.          if(l .eq. 1)p_gc(i,j,1)=psc(i,j)
    5018. 

  5018.         enddo
    5019. 

  5019.        enddo
    5020. 

  5020.      enddo
    5021. 

  5021. 

  5022.       WRITE(0,*)'--------------- new ght_gc --------------------------'
    5023. 

  5023.       WRITE(0,*)ght_gc(100,100,:)
    5024. 

  5024.       WRITE(0,*)'--------------- new p_gc --------------------------'
    5025. 

  5025.       WRITE(0,*)p_gc(100,100,:)
    5026. 

  5026.       WRITE(0,*)'--------------- new rh_gc ---------------------------'
    5027. 

  5027.       WRITE(0,*)rh_gc(100,100,:)
    5028. 

  5028.       WRITE(0,*)'--------------- new t_gc --------------------------'
    5029. 

  5029.       WRITE(0,*)t_gc(100,100,:)
    5030. 

  5030.       WRITE(0,*)'---------------------------------------------------'
    5031. 

  5031. 

  5032.       WRITE(0,*)'tcbogus completed'
    5033. 

  5033. 

  5034.    ENDIF  ! for internal_time_loop .eq. 1
    5035. 

  5035. 

  5036.   ENDIF  ! endif for beta=0.- 1.5
    5037. 

  5037. 

  5038.  END SUBROUTINE vortex
    5039. 

  5039. 

  5040. !-------------------------------------------------------------------------
    5041. 

  5041. !   SUBROUTINE hbfilter
    5042. 

  5042. !   -------------------
    5043. 

  5043. !   input              - field to be filtered
    5044. 

  5044. !   output             - filtered output
    5045. 

  5045. !   nmax               - recrussive application of filter ( suggested 3 for 9 km and 27 for 3 km)
    5046. 

  5046. !   start_z,end_zstart - usually 1 to ktop
    5047. 

  5047. !   ids,ide,jds,jde    - domain index, namely,imin,imax,jmin,jmax
    5048. 

  5048. !   ims,ime,jms,jme    - memory index, for 1 processor set this to above values
    5049. 

  5049. !   its,ite,jts,jte    - tile index, for 1 processor set this to above values
    5050. 

  5050. 

  5051. 

  5052.  SUBROUTINE hbfilter ( input, output        &
    5053. 

  5053.      &,                nmax,start_z,end_z   &
    5054. 

  5054.      &,                ids,ide,jds,jde      &
    5055. 

  5055.      &,                ims,ime,jms,jme      &
    5056. 

  5056.      &,                its,ite,jts,jte      )
    5057. 

  5057.  IMPLICIT NONE
    5058. 

  5058. 

  5059.  INTEGER, INTENT(IN)                                          :: ids,ide,jds,jde,ims,ime,jms,jme,its,ite,jts,jte
    5060. 

  5060.  INTEGER, INTENT(IN)                                          :: start_z,end_z,nmax
    5061. 

  5061.  REAL                                                         :: dx
    5062. 

  5062.  REAL, DIMENSION(IMS:IME,JMS:JME,start_z:end_z),INTENT(IN)    :: INPUT
    5063. 

  5063.  REAL, DIMENSION(IMS:IME,JMS:JME,start_z:end_z),INTENT(INOUT) :: OUTPUT
    5064. 

  5064. 

  5065. ! local
    5066. 

  5066. 

  5067.  INTEGER :: I,J,K,N,JMIN,JMAX,IMIN,IMAX,NRES,REPEAT
    5068. 

  5068.  REAL    :: PI
    5069. 

  5069.  REAL, DIMENSION(11) :: M
    5070. 

  5070.  DATA M /2,3,4,2,5,6,7,2,8,9,2/
    5071. 

  5071.  INTEGER, PARAMETER          :: NF=11
    5072. 

  5072.  REAL, DIMENSION(NF)         :: FK
    5073. 

  5073.  REAL, DIMENSION(IMS:IME,NF) :: XTU
    5074. 

  5074.  REAL, DIMENSION(JMS:JME,NF) :: YTU
    5075. 

  5075. 

  5076. 

  5077. !------------------------------------------------------------------
    5078. 

  5078. !
    5079. 

  5079. !     Purpose: This routine filters and removes
    5080. 

  5080. !              hurricane signals (Kurihara et al., 1993, MWR)
    5081. 

  5081. !
    5082. 

  5082. !     Called from: vortex
    5083. 

  5083. !
    5084. 

  5084. !     Original Code: Qingfu Liu (EMC)
    5085. 

  5085. !     Modification history: This is gopal's doing
    5086. 

  5086. !-----------------------------------------------------------------
    5087. 

  5087. !
    5088. 

  5088. !   DOMAIN
    5089. 

  5089. 

  5090.     IMIN=1     !(1,ID0-40)
    5091. 

  5091.     IMAX=IDE-1 !min(IDE-1,ID0+40)
    5092. 

  5092.     JMIN=1     !max(1,JD0-67)
    5093. 

  5093.     JMAX=JDE-1 !min(JDE-1,JD0+67)
    5094. 

  5094. 

  5095. !   INPUT:  Local variable defined for testing
    5096. 

  5096. 

  5097.     PI=4.0* ATAN(1.0)
    5098. 

  5098.     DO K=start_z,end_z
    5099. 

  5099.     DO J=JMIN,JMAX
    5100. 

  5100.     DO I=IMIN,IMAX
    5101. 

  5101.       OUTPUT(I,J,K)= INPUT(I,J,K) !SIN(2.0*PI/(21-1)*(I-1)) ! INPUT(I,J,K)
    5102. 

  5102.     ENDDO
    5103. 

  5103.     ENDDO
    5104. 

  5104.     ENDDO
    5105. 

  5105. 

  5106. !   DEFINE FILTER FUNCTION
    5107. 

  5107. 

  5108.     DO N=1,NF
    5109. 

  5109.       FK(N)=0.5/(1-COS(2.*PI/M(N)))
    5110. 

  5110.     ENDDO
    5111. 

  5111. 

  5112.     DO K=start_z,end_z
    5113. 

  5113. 

  5114. !.. DO ZONAL FILTER
    5115. 

  5115. 

  5116.      DO REPEAT=1,nmax
    5117. 

  5117.        DO J=JMIN,JMAX-1
    5118. 

  5118.         DO N=1,NF
    5119. 

  5119.          XTU(IMIN,N)   = OUTPUT(IMIN,J,K)
    5120. 

  5120.          XTU(IMAX,N)   = OUTPUT(IMAX,J,K)
    5121. 

  5121.         ENDDO
    5122. 

  5122. 

  5123.         DO I=IMIN+1,IMAX-1
    5124. 

  5124.          XTU(I,1) = OUTPUT(I,J,K)+FK(1)*(OUTPUT(I-1,J,K)+OUTPUT(I+1,J,K)-2.*OUTPUT(I,J,K))
    5125. 

  5125.         ENDDO
    5126. 

  5126. 

  5127.         DO N=2,NF
    5128. 

  5128.         DO I=IMIN+1,IMAX-1
    5129. 

  5129.            XTU(I,N)=XTU(I,N-1)+FK(N)*(XTU(I-1,N-1)+XTU(I+1,N-1)-2.*XTU(I,N-1))
    5130. 

  5130.         ENDDO
    5131. 

  5131.         ENDDO
    5132. 

  5132. 

  5133.         DO I=IMIN,IMAX-1
    5134. 

  5134.            OUTPUT(I,J,K) = XTU(I,NF)
    5135. 

  5135.         ENDDO
    5136. 

  5136.        ENDDO ! J loop
    5137. 

  5137.      ENDDO   ! End recrussive repeat
    5138. 

  5138. 

  5139. !.. DO MERIDIONAL FILTER
    5140. 

  5140. 

  5141.      DO REPEAT=1,nmax
    5142. 

  5142.        DO I=IMIN,IMAX
    5143. 

  5143.         DO N=1,NF
    5144. 

  5144.          YTU(JMIN,N) = OUTPUT(I,JMIN,K)
    5145. 

  5145.          YTU(JMAX,N) = OUTPUT(I,JMAX,K)
    5146. 

  5146.         ENDDO
    5147. 

  5147. 

  5148.         DO J=JMIN+1,JMAX-1
    5149. 

  5149.          YTU(J,1) = OUTPUT(I,J,K) + FK(1)*(OUTPUT(I,J-1,K) + OUTPUT(I,J+1,K) -2.*OUTPUT(I,J,K))
    5150. 

  5150.         ENDDO
    5151. 

  5151. 

  5152.         DO N = 2,NF
    5153. 

  5153.         DO J = JMIN+1,JMAX-1
    5154. 

  5154.          YTU(J,N) = YTU(J,N-1) + FK(N)*(YTU(J-1,N-1)  + YTU(J+1,N-1) - 2.*YTU(J,N-1))
    5155. 

  5155.         ENDDO
    5156. 

  5156.         ENDDO
    5157. 

  5157. 

  5158.         DO J = JMIN,JMAX-1
    5159. 

  5159.          OUTPUT(I,J,K)   =  YTU(J,NF)
    5160. 

  5160.         ENDDO
    5161. 

  5161.        ENDDO ! I loop
    5162. 

  5162.      ENDDO   ! End recrussive repeat
    5163. 

  5163. 

  5164.     ENDDO  ! K loop
    5165. 

  5165.     RETURN
    5166. 

  5166. 

  5167. 

  5168.  END SUBROUTINE hbfilter
    5169. 

  5169. !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++c
    5170. 

  5170. !  This program performs the idealized vortex initialization for ARW_WRF    c
    5171. 

  5171. !  was written by Zhihua Zeng (Shanghai Typhoon Institute/CMA) and Jian-Wen c
    5172. 

  5172. !  Bao (NOAA/PSD) in 2009.                                                  c
    5173. 

  5173. !                                                                           c
    5174. 

  5174. !  Contact Eamil:                                                           c
    5175. 

  5175. !           zengzh@mail.typhoon.gov.cn or Jian-Wen.Bao@noaa.gov             c
    5176. 

  5176. !                                                                           c
    5177. 

  5177. !  References:                                                              c
    5178. 

  5178. !           Wang Y.,1995:On inverse balance equation in sigma-coordinates   c
    5179. 

  5179. !                   for model initialization, MWR, 123, 482-488.            c
    5180. 

  5180. !           Zeng Z. et al,2009: Simulation of spiral rainbands and vertical c
    5181. 

  5181. !                   resolution, 10th annual WRF user's workshop,23-26 June, c
    5182. 

  5182. !                   Boulder,CO.                                             c
    5183. 

  5183. !
    5184. 

  5184. !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    5185. 

  5185. !  This program performs the vortex initialisation using a nonlinear
    5186. 

  5186. !  balance equation in sigma coordinate following  Wang  (1995, MWR)
    5187. 

  5187. !  but with some modifications.
    5188. 

  5188. !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    5189. 

  5189.       subroutine  tcbogus( uw,vw,tw,ghw,rhw,psc         &
    5190. 

  5190.      &,                    dsc,id1,jd1                  &
    5191. 

  5191.      &,                    start_z,end_z1               &
    5192. 

  5192.      &,                    ids,ide,jds,jde              &
    5193. 

  5193.      &,                    ims,ime,jms,jme              &
    5194. 

  5194.      &,                    its,ite,jts,jte              )
    5195. 

  5195.       implicit none
    5196. 

  5196.       include 'BALANCE_PARS.F'
    5197. 

  5197.       include 'BALANCE_COMS.F'
    5198. 

  5198. 

  5199.       INTEGER, INTENT(IN):: start_z,end_z1,id1,jd1
    5200. 

  5200.       INTEGER, INTENT(IN):: ids,ide,jds,jde,ims,ime,jms,jme,its,ite,jts,jte
    5201. 

  5201. !
    5202. 

  5202.       REAL,                                          INTENT(IN)    :: dsc
    5203. 

  5203.       REAL, DIMENSION(IMS:IME,JMS:JME),              INTENT(INOUT) :: psc
    5204. 

  5204.       REAL, DIMENSION(IMS:IME,JMS:JME,start_z:end_z1),INTENT(INOUT) :: uw,vw,tw,ghw,rhw
    5205. 

  5205. 

  5206. ! local variables
    5207. 

  5207.       INTEGER, PARAMETER                                :: nv=30
    5208. 

  5208.       INTEGER                                           :: i,j,k,km,kd,indx,jtc,itc
    5209. 

  5209.       INTEGER                                           :: ji,ii,itime,jjt,nwest
    5210. 

  5210.       REAL                                              :: f0,beta0,beta,pia,betk,txc,tyc,sigma
    5211. 

  5211.       REAL                                              :: tk,t6,rh,rm,vm0,rm0,ts
    5212. 

  5212.       REAL, DIMENSION(JMS:JME)                          :: fc,fe
    5213. 

  5213.       REAL, DIMENSION(start_z:end_z1)                   :: up1,pp1,pp1o
    5214. 

  5214.       REAL, DIMENSION(start_z:end_z1-1)                 :: up,tvb
    5215. 

  5215.       REAL, DIMENSION(IMS:IME,JMS:JME)                  :: betkc
    5216. 

  5216.       REAL, DIMENSION(IMS:IME,JMS:JME,start_z:end_z1-1) :: uc,vc,tc,rqc,ppc
    5217. 

  5217.       REAL, DIMENSION(IMS:IME,JMS:JME,start_z:end_z1-1) :: tvbc,ghc,rhc
    5218. 

  5218. !
    5219. 

  5219.       common /comp1/tk(kmx),t6(kmx1),rh(kmx),rm,vm0,ts
    5220. 

  5220.       km=end_z1-1
    5221. 

  5221. !
    5222. 

  5222. !*******************************************************************
    5223. 

  5223.       open(22,file='sigma.d',form='formatted')
    5224. 

  5224.       do k=1,end_z1
    5225. 

  5225.       read(22,*) kd, sig(k)
    5226. 

  5226.       enddo
    5227. 

  5227.   5   format(2x,i2,4x,f10.6)
    5228. 

  5228.       close(22)
    5229. 

  5229. 

  5230.       do k=1,km
    5231. 

  5231.       sig1(k)=0.5*(sig(k)+sig(k+1))
    5232. 

  5232.       enddo
    5233. 

  5233. !
    5234. 

  5234.       open(20,file='input.d',form='formatted',status='unknown')
    5235. 

  5235.       read(20,1) indx
    5236. 

  5236.       read(20,2) nenv
    5237. 

  5237.       read(20,3) vm0
    5238. 

  5238.       read(20,3) rm0
    5239. 

  5239. !     read(20,4) tsf0
    5240. 

  5240.       close(20)
    5241. 

  5241.   1   format(i1)
    5242. 

  5242.   2   format(i2)
    5243. 

  5243.   3   format(f5.1)
    5244. 

  5244.   4   format(f8.2)
    5245. 

  5245. !
    5246. 

  5246.       rm=rm0*1000.0
    5247. 

  5247. !
    5248. 

  5248. !     write(6,*) vm0,rm0
    5249. 

  5249. !     write(6,*) nenv
    5250. 

  5250. !
    5251. 

  5251.       do k=1,km
    5252. 

  5252.       up(k)=0.0
    5253. 

  5253.       enddo
    5254. 

  5254.       do k=1,end_z1
    5255. 

  5255.       up1(k)=0.0
    5256. 

  5256.       enddo
    5257. 

  5257.       jjt=0.0
    5258. 

  5258. !
    5259. 

  5259.       nwest=-(ide-1)/2+25
    5260. 

  5260.       jjt=max(jjt,nwest)
    5261. 

  5261.       write(6,*) jjt
    5262. 

  5262. !
    5263. 

  5263.       txc=id1  !(float(ide)+1.0)/3.0 !2.0
    5264. 

  5264.       tyc=jd1  !(float(jde)+1.0)/3.0 !2.0
    5265. 

  5265.       write(6,*)'txc= ', txc,'tyc= ',tyc
    5266. 

  5266. !
    5267. 

  5267.       call tem(tk,t6,rh,km,end_z1,pp1)
    5268. 

  5268. !
    5269. 

  5269.       ts=t6(end_z1)
    5270. 

  5270.       write(6,*) ts
    5271. 

  5271. !-------------------------------------
    5272. 

  5272. !--to calculate the Coriolis parameter
    5273. 

  5273. !-------------------------------------
    5274. 

  5274.       pia=4.0*atan(1.0)/180.0
    5275. 

  5275.       f0=14.584e-5*sin(pia*fi0)
    5276. 

  5276.       beta=14.584e-5*cos(pia*fi0)/6.3712e6
    5277. 

  5277.       if(indx.eq.0) beta=0.0
    5278. 

  5278.       do i=1,jde
    5279. 

  5279.       fc(i)=f0+beta*(float(i)-tyc)*dsc
    5280. 

  5280.       enddo
    5281. 

  5281. !---------------------------------------------------
    5282. 

  5282.       call env(tc,psc,fc,ide,jde,dsc,tyc,up1,km,end_z1)
    5283. 

  5283. !---------------------------------------------------
    5284. 

  5284.       do k=1,km
    5285. 

  5285.       do i=1,jde
    5286. 

  5286.       do j=1,ide
    5287. 

  5287.       tc(j,i,k)=tk(k)+tc(j,i,k)
    5288. 

  5288.       enddo
    5289. 

  5289.       enddo
    5290. 

  5290.       enddo
    5291. 

  5291. !
    5292. 

  5292.       call result(uc,vc,tc,rqc,psc,fc,ide,jde,dsc,tyc,txc, &
    5293. 

  5293.               up1,up,km,end_z1,beta)
    5294. 

  5294. 

  5295.       write(0,*)'out of result'
    5296. 

  5296. !
    5297. 

  5297.       itime=0.0
    5298. 

  5298. !
    5299. 

  5299.       do k=1,km
    5300. 

  5300.        qb(k)=rqc(1,1,k)
    5301. 

  5301.       enddo
    5302. 

  5302. !
    5303. 

  5303.       do i=1,jde
    5304. 

  5304.       do k=1,km
    5305. 

  5305.       do j=1,ide
    5306. 

  5306.       ppc(j,i,k)=sig1(k)*psc(j,i)
    5307. 

  5307.       enddo
    5308. 

  5308.       enddo
    5309. 

  5309.       enddo
    5310. 

  5310. !
    5311. 

  5311. !--------------------------------------
    5312. 

  5312. !--to calculate the height of the u,v,t
    5313. 

  5313. !--------------------------------------
    5314. 

  5314.       do k=1,km
    5315. 

  5315.       tvb(k)=tk(k)*(1.0+0.608*qb(k))
    5316. 

  5316.       enddo
    5317. 

  5317.       betk=(rgas/grv)*log(1.0/sig1(km))
    5318. 

  5318.       poz(km)=betk*tvb(km)
    5319. 

  5319. !     write(10,*) poz(km)
    5320. 

  5320.       do k=km-1,1,-1
    5321. 

  5321.       betk=0.5*(rgas/grv)*log(sig1(k+1)/sig1(k))
    5322. 

  5322.       poz(k)=poz(k+1)+betk*(tvb(k)+tvb(k+1))
    5323. 

  5323. !     write(10,*) poz(k)
    5324. 

  5324.       enddo
    5325. 

  5325. !
    5326. 

  5326.       write(0,*)'before interpolation'
    5327. 

  5327.       call interpz(uc,vc,tc,ppc,rqc,ide,jde,km)
    5328. 

  5328. !
    5329. 

  5329.       if(vm0.gt.1.0) then
    5330. 

  5330. !
    5331. 

  5331. !--------------------------------------
    5332. 

  5332.       do k=1,km
    5333. 

  5333.        do i=1,jde
    5334. 

  5334.         do j=1,ide
    5335. 

  5335.       rhc(j,i,k)=rh(k)
    5336. 

  5336.       fe(i)=0.0
    5337. 

  5337.         enddo
    5338. 

  5338.        enddo
    5339. 

  5339.       enddo
    5340. 

  5340. 

  5341. !--------------------------------------
    5342. 

  5342.       do k=1,km
    5343. 

  5343.        do i=1,jde
    5344. 

  5344.         do j=1,ide
    5345. 

  5345.       tvbc(j,i,k)=tc(j,i,k)*(1.0+0.608*rqc(j,i,k))
    5346. 

  5346.         enddo
    5347. 

  5347.        enddo
    5348. 

  5348.       enddo
    5349. 

  5349.        do i=1,jde
    5350. 

  5350.         do j=1,ide
    5351. 

  5351.       betkc(j,i)=(rgas/grv)*log(0.01*psc(j,i)/pp1(km))  !! psc is hPa
    5352. 

  5352.       ghc(j,i,km)=betkc(j,i)*tvbc(j,i,km)
    5353. 

  5353.         enddo
    5354. 

  5354.        enddo
    5355. 

  5355.       do k=km-1,1,-1
    5356. 

  5356.        do i=1,jde
    5357. 

  5357.         do j=1,ide
    5358. 

  5358. !        write(63,*)k,i,j,pp1(k+1),pp1(k)
    5359. 

  5359.         if(pp1(k) .gt. 0.)then
    5360. 

  5360.          betkc(j,i)=0.5*(rgas/grv)*log(pp1(k+1)/pp1(k))
    5361. 

  5361.         else
    5362. 

  5362.          betkc(j,i)=0.0
    5363. 

  5363.         endif
    5364. 

  5364.          ghc(j,i,k)=ghc(j,i,k+1)+betkc(j,i)*(tvbc(j,i,k)+tvbc(j,i,k+1))
    5365. 

  5365.         enddo
    5366. 

  5366.        enddo
    5367. 

  5367.       enddo
    5368. 

  5368. !
    5369. 

  5369.       write(0,*)'---------- test write out -----------'
    5370. 

  5370.       do k=1,km
    5371. 

  5371.        do i=1,jde
    5372. 

  5372.         do j=1,ide
    5373. 

  5373.          uw(j,i,k)=uc(j,i,k)
    5374. 

  5374.          vw(j,i,k)=vc(j,i,k)
    5375. 

  5375.          tw(j,i,k)=tc(j,i,k)
    5376. 

  5376.          ghw(j,i,k)=ghc(j,i,k)
    5377. 

  5377.          rhw(j,i,k)=rhc(j,i,k)
    5378. 

  5378.          if(i .eq. 10 .and. j .eq. 10)write(0,*)k,uw(j,i,k),vw(j,i,k),ghw(j,i,k),tw(j,i,k)
    5379. 

  5379.          if(i .eq. 100 .and. j .eq. 98)write(0,*)k,uw(j,i,k),vw(j,i,k),ghw(j,i,k),tw(j,i,k)
    5380. 

  5380.         enddo
    5381. 

  5381.        enddo
    5382. 

  5382.       enddo
    5383. 

  5383. 

  5384.       endif
    5385. 

  5385. !
    5386. 

  5386.       return
    5387. 

  5387.       end subroutine  tcbogus
    5388. 

  5388. !
    5389. 

  5389. !-----------------------------------------------------------------
    5390. 

  5390. !
    5391. 

  5391.       subroutine result(u,v,t,rq,ps,f,lq,lp,ds,ty0,tx0,up1, &
    5392. 

  5392.                        up,km,end_z1,beta)
    5393. 

  5393. !
    5394. 

  5394. !-----------------------------------------------------------------
    5395. 

  5395.       implicit none
    5396. 

  5396.       include 'BALANCE_PARS.F'
    5397. 

  5397.       include 'BALANCE_COMS.F'
    5398. 

  5398.       integer i,j,k,lq,lp,km,end_z1,nnt,jti,iti
    5399. 

  5399.       real ds,ds2,err,uee,tx0,ty0,beta,ajac,vor,forc1,forc2,forc3
    5400. 

  5400.       real ees,rqs,sgg,reh,ta,pp,alpi
    5401. 

  5401.       real u(lq,lp,km),v(lq,lp,km),t(lq,lp,km),rq(lq,lp,km),ps(lq,lp)
    5402. 

  5402.       real alp(lq,lp),tt(lq,lp,end_z1),tt2(2:km),xx(lq,lp),forc(lq,lp)
    5403. 

  5403.       real ux(lq,lp),vy(lq,lp),tt1(lq,lp,km),gg1(lq,lp,end_z1),f(lp)
    5404. 

  5404.       real up1(end_z1),up(km)
    5405. 

  5405.       real tk,t6,rh,rm,vm0,ts
    5406. 

  5406.       common /comp1/tk(kmx),t6(kmx1),rh(kmx),rm,vm0,ts
    5407. 

  5407. !
    5408. 

  5408.       ds2=ds*ds
    5409. 

  5409.       err=3.0e-6
    5410. 

  5410.       do i=1,lp
    5411. 

  5411.       do j=1,lq
    5412. 

  5412.        forc(j,i)=0.0
    5413. 

  5413.        alp(j,i)=log(ps(j,i))
    5414. 

  5414.       enddo
    5415. 

  5415.       enddo
    5416. 

  5416. !
    5417. 

  5417.       uee=up1(end_z1)
    5418. 

  5418. 

  5419.       WRITE(0,*)'CALLING VORTEX 1'
    5420. 

  5420. 

  5421.       call vortex1(ux,vy,1.0,ds,lq,lp,ty0,tx0,uee)
    5422. 

  5422.       do 1 i=2,lp-1
    5423. 

  5423.       do 1 j=2,lq-1
    5424. 

  5424.       ajac=((ux(j+1,i)-ux(j-1,i))*(vy(j,i+1)-vy(j,i-1))-(ux(j,i+1) &
    5425. 

  5425.          -ux(j,i-1))*(vy(j+1,i)-vy(j-1,i)))/(2.0*ds2)
    5426. 

  5426.       vor=f(i)*(vy(j+1,i)-vy(j-1,i)-ux(j,i+1)+ux(j,i-1))/(2.0*ds)
    5427. 

  5427.       forc(j,i)=ds2*(ajac+vor-beta*ux(j,i))/(rgas*ts)
    5428. 

  5428.   1   continue
    5429. 

  5429.       call posn(alp,forc,5.0e-10,1,lq,lp)
    5430. 

  5430. 

  5431.       do i=1,lp
    5432. 

  5432.       do j=1,lq
    5433. 

  5433.         ps(j,i)=exp(alp(j,i))
    5434. 

  5434.       enddo
    5435. 

  5435.       enddo
    5436. 

  5436.      do 2 i=1,lp
    5437. 

  5437.       do 2 j=1,lq
    5438. 

  5438.       do 2 k=1,km
    5439. 

  5439.       t(j,i,k)=t(j,i,k)-tk(k)
    5440. 

  5440.    2  continue
    5441. 

  5441. !
    5442. 

  5442.       do 5 k=1,end_z1
    5443. 

  5443. !
    5444. 

  5444.       sgg=sig(k)
    5445. 

  5445.       uee=up1(k)
    5446. 

  5446. 

  5447.       WRITE(0,*)'CALLING VORTEX 2',k
    5448. 

  5448. 

  5449.       call vortex1(ux,vy,sgg,ds,lq,lp,ty0,tx0,uee)
    5450. 

  5450.       do 3 i=2,lp-1
    5451. 

  5451.       do 3 j=2,lq-1
    5452. 

  5452.       ajac=((ux(j+1,i)-ux(j-1,i))*(vy(j,i+1)-vy(j,i-1))-(ux(j,i+1) &
    5453. 

  5453.          -ux(j,i-1))*(vy(j+1,i)-vy(j-1,i)))/(2.0*ds2)
    5454. 

  5454.       vor=f(i)*(vy(j+1,i)-vy(j-1,i)-ux(j,i+1)+ux(j,i-1))/(2.0*ds)
    5455. 

  5455.       gg1(j,i,k)=ajac+vor-beta*ux(j,i)
    5456. 

  5456.   3   continue
    5457. 

  5457. !
    5458. 

  5458.   5   continue
    5459. 

  5459. !
    5460. 

  5460.       nnt=0
    5461. 

  5461.    6  nnt=nnt+1
    5462. 

  5462. !
    5463. 

  5463.       do 8 j=1,lq
    5464. 

  5464.       do 8 i=1,lp
    5465. 

  5465.       do k=2,km
    5466. 

  5466.       tt2(k)=t(j,i,k-1)+(t(j,i,k)-t(j,i,k-1))*(sig(k)-sig1(k-1)) &
    5467. 

  5467.               /(sig1(k)-sig1(k-1))
    5468. 

  5468.       enddo
    5469. 

  5469.       do k=1,km
    5470. 

  5470.       if(k.eq.1) then
    5471. 

  5471.       tt(j,i,k)=(tt2(k+1)-t(j,i,k))/log(sig(k+1)/sig1(k))
    5472. 

  5472.       else if(k.eq.km) then
    5473. 

  5473.       tt(j,i,k)=(t(j,i,k)-tt2(k))/log(sig1(k)/sig(k))
    5474. 

  5474.       else
    5475. 

  5475.       tt(j,i,k)=(tt2(k+1)-tt2(k))/log(sig(k+1)/sig(k))
    5476. 

  5476.       endif
    5477. 

  5477.       enddo
    5478. 

  5478.    8  continue
    5479. 

  5479. !
    5480. 

  5480.       do 15 k=1,km
    5481. 

  5481. !
    5482. 

  5482.       do 9 j=2,lq-1
    5483. 

  5483.       do 9 i=2,lp-1
    5484. 

  5484.       alpi=alp(j-1,i)+alp(j,i-1)-4.0*alp(j,i)+alp(j+1,i)+alp(j,i+1)
    5485. 

  5485.       if(k.eq.1) then
    5486. 

  5486.       forc1=(t6(k+1)-tk(k))*alpi/log(sig(k+1)/sig1(k))
    5487. 

  5487.       forc3=(gg1(j,i,k+1)-gg1(j,i,k+2))*ds2/ &
    5488. 

  5488.                      (rgas*log(sig(k+2)/sig(k+1)))
    5489. 

  5489.       else
    5490. 

  5490.       forc1=(t6(k+1)-t6(k))*alpi/log(sig(k+1)/sig(k))
    5491. 

  5491.       forc3=(gg1(j,i,k)-gg1(j,i,k+1))*ds2/(rgas*log(sig(k+1)/sig(k)))
    5492. 

  5492.       endif
    5493. 

  5493.       forc2=(tt(j+1,i,k)+tt(j,i,k))*(alp(j+1,i)-alp(j,i))-(tt(j,i,k)+ &
    5494. 

  5494.         tt(j-1,i,k))*(alp(j,i)-alp(j-1,i))+(tt(j,i+1,k)+tt(j,i,k))*(alp &
    5495. 

  5495.         (j,i+1)-alp(j,i))-(tt(j,i,k)+tt(j,i-1,k))*(alp(j,i)-alp(j,i-1))
    5496. 

  5496.       forc(j,i)=forc1+0.5*forc2+forc3
    5497. 

  5497.   9   continue
    5498. 

  5498.       do 10 j=1,lq
    5499. 

  5499.       do 10 i=1,lp
    5500. 

  5500.       xx(j,i)=t(j,i,k)
    5501. 

  5501.   10  continue
    5502. 

  5502. !
    5503. 

  5503.       call posn(xx,forc,err,nnt,lq,lp)
    5504. 

  5504. !
    5505. 

  5505.       do 12 j=1,lq
    5506. 

  5506.       do 12 i=1,lp
    5507. 

  5507.   12  t(j,i,k)=xx(j,i)
    5508. 

  5508. !
    5509. 

  5509.   15  continue
    5510. 

  5510. !
    5511. 

  5511.       if(nnt.ne.4) goto 6
    5512. 

  5512. !
    5513. 

  5513.       jti=int(tx0+0.5)
    5514. 

  5514.       iti=int(ty0+0.5)
    5515. 

  5515. !
    5516. 

  5516.       do k=1,km
    5517. 

  5517.       write(6,*) t(jti,iti,k)
    5518. 

  5518.       enddo
    5519. 

  5519. !
    5520. 

  5520.       do 18 k=1,km
    5521. 

  5521.       do 18 i=1,lp
    5522. 

  5522.       do 18 j=1,lq
    5523. 

  5523.       t(j,i,k)=t(j,i,k)+tk(k)
    5524. 

  5524.       reh=amin1(1.0,rh(k)*0.01)
    5525. 

  5525.       if(nphy.eq.0) reh=0.0
    5526. 

  5526.       pp=sig1(k)*ps(j,i)
    5527. 

  5527.       ta=t(j,i,k)
    5528. 

  5528.       ees=611.2*exp(cs2*(ta-cs3)/(ta-cs4))
    5529. 

  5529.       ees=amin1(0.5*pp,ees)
    5530. 

  5530.       rqs=0.622*ees/(pp-ees)
    5531. 

  5531.       rq(j,i,k)=reh*rqs
    5532. 

  5532.   18  continue
    5533. 

  5533. !
    5534. 

  5534.       do 20 k=1,km
    5535. 

  5535.       sgg=sig1(k)
    5536. 

  5536.       uee=up(k)
    5537. 

  5537. 

  5538.       WRITE(0,*)'CALLING VORTEX 3',k
    5539. 

  5539. 

  5540.       call vortex1(ux,vy,sgg,ds,lq,lp,ty0,tx0,uee)
    5541. 

  5541.       do 20 i=1,lp
    5542. 

  5542.       do 20 j=1,lq
    5543. 

  5543.      u(j,i,k)=ux(j,i)
    5544. 

  5544.       v(j,i,k)=vy(j,i)
    5545. 

  5545.   20  continue
    5546. 

  5546. !
    5547. 

  5547.       return
    5548. 

  5548.       end subroutine result
    5549. 

  5549. !
    5550. 

  5550. !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    5551. 

  5551. !
    5552. 

  5552.       subroutine vortex1(ux,vy,sgg,ds,lq,lp,ty0,tx0,uee)
    5553. 

  5553. !
    5554. 

  5554. !----------------------------------------------------------------
    5555. 

  5555.       implicit none
    5556. 

  5556.       include 'BALANCE_PARS.F'
    5557. 

  5557.       integer i,j,lq,lp
    5558. 

  5558.       real ahem,pi,sgt,sgb,sgg,ds,ty0,tx0,uee,vm,b,r0,rr,rd,ty,tx
    5559. 

  5559.       real ux(lq,lp),vy(lq,lp)
    5560. 

  5560.       real tk,t6,rh,rm,vm0,ts,vt
    5561. 

  5561.       common /comp1/tk(kmx),t6(kmx1),rh(kmx),rm,vm0,ts
    5562. 

  5562. !
    5563. 

  5563.       WRITE(0,*)'INSIDE VORTEX'
    5564. 

  5564.       ahem=1.0
    5565. 

  5565.       if(fi0.lt.0.0) ahem=-1.0
    5566. 

  5566.       pi=2.0*atan(1.0)
    5567. 

  5567.       sgt=0.15
    5568. 

  5568.       sgb=0.95
    5569. 

  5569.       if(sgg.ge.sgb) then
    5570. 

  5570.         vm=vm0
    5571. 

  5571.       else if(sgg.le.sgt) then
    5572. 

  5572.         vm=0.0
    5573. 

  5573.       else
    5574. 

  5574.         vm=vm0*sin(pi*(sgg-sgt)/(sgb-sgt))
    5575. 

  5575.       endif
    5576. 

  5576. !
    5577. 

  5577.       b=1.0
    5578. 

  5578.       r0=10.0*rm
    5579. 

  5579.       do i=1,lp
    5580. 

  5580.       ty=(float(i)-ty0)*ds
    5581. 

  5581.       do j=1,lq
    5582. 

  5582.       tx=(float(j)-tx0)*2.0*ds  ! factor 2.0: gopal's doing for E grid
    5583. 

  5583.       rr=sqrt(ty*ty+tx*tx)
    5584. 

  5584.       rd=rr/rm
    5585. 

  5585.       vt=vm/rm*(exp((1.0-rd**b)/b)-abs(rr-rm)/(r0-rm) &
    5586. 

  5586.           *exp((1.0-(r0/rm)**b)/b))
    5587. 

  5587.       if(rr.ge.r0) vt=0.0
    5588. 

  5588.       ux(j,i)=-vt*ty*ahem+uee
    5589. 

  5589.       vy(j,i)=vt*tx*ahem
    5590. 

  5590.      enddo
    5591. 

  5591.       enddo
    5592. 

  5592. !
    5593. 

  5593.       return
    5594. 

  5594.       end subroutine vortex1
    5595. 

  5595. !
    5596. 

  5596. !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    5597. 

  5597. !
    5598. 

  5598.       subroutine posn(xx,forc,err,nnt,lq,lp)
    5599. 

  5599. !
    5600. 

  5600. !--------------------------------------------------------
    5601. 

  5601.       implicit none
    5602. 

  5602.       include 'BALANCE_PARS.F'
    5603. 

  5603.       include 'BALANCE_COMS.F'
    5604. 

  5604. !
    5605. 

  5605.       integer i,j,nnt,lq,lp
    5606. 

  5606.       real xx(lq,lp),forc(lq,lp),err
    5607. 

  5607.       real*8 rji,ane,arm,anorm
    5608. 

  5608.       real*8 tem(lq,lp),wk(lq,lp),fc(lq,lp)
    5609. 

  5609. !
    5610. 

  5610.       do i=1,lp
    5611. 

  5611.       do j=1,lq
    5612. 

  5612.       tem(j,i)=xx(j,i)
    5613. 

  5613.       fc(j,i)=forc(j,i)
    5614. 

  5614.       enddo
    5615. 

  5615.       enddo
    5616. 

  5616. !
    5617. 

  5617.       if(nnt.eq.1.and.nenv.ne.0) then
    5618. 

  5618.       do 1 i=2,lp-1
    5619. 

  5619.       do 1 j=2,lq-1
    5620. 

  5620.       tem(j,i)=tem(j,i)-0.25*fc(j,i)
    5621. 

  5621.   1   continue
    5622. 

  5622.       endif
    5623. 

  5623. !
    5624. 

  5624.       nt=0
    5625. 

  5625.   2   nt=nt+1
    5626. 

  5626. !
    5627. 

  5627.       anorm=0.0d0
    5628. 

  5628. !
    5629. 

  5629.       do 10 i=2,lp-1
    5630. 

  5630.       do 10 j=2,lq-1
    5631. 

  5631.       rji=fc(j,i)-(tem(j-1,i)+tem(j,i-1)+ &
    5632. 

  5632.         tem(j+1,i)+tem(j,i+1)-4.0d0*tem(j,i))
    5633. 

  5633.       ane=-0.25d0*rji
    5634. 

  5634.       wk(j,i)=tem(j,i)+ane
    5635. 

  5635.       arm=abs(ane)
    5636. 

  5636.       if(arm.gt.anorm) anorm=arm
    5637. 

  5637.   10  continue
    5638. 

  5638. !
    5639. 

  5639.       do 20 i=2,lp-1
    5640. 

  5640.       do 20 j=2,lq-1
    5641. 

  5641.   20  tem(j,i)=wk(j,i)
    5642. 

  5642. !
    5643. 

  5643.       do i=1,lp
    5644. 

  5644.       do j=1,lq
    5645. 

  5645.       xx(j,i)=tem(j,i)
    5646. 

  5646.       enddo
    5647. 

  5647.       enddo
    5648. 

  5648. !
    5649. 

  5649.       return
    5650. 

  5650.       end subroutine posn
    5651. 

  5651. !
    5652. 

  5652. !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    5653. 

  5653. !
    5654. 

  5654.       subroutine tem(ttk,ttk1,rh,km,end_z1,pp1)
    5655. 

  5655. !
    5656. 

  5656. !----------------------------------------------------------------
    5657. 

  5657.       implicit none
    5658. 

  5658.       include 'BALANCE_PARS.F'
    5659. 

  5659.       include 'BALANCE_COMS.F'
    5660. 

  5660.       integer km,end_z1,nv,k,n1
    5661. 

  5661.       parameter(nv=30)
    5662. 

  5662.       real ppk(km),ttk(km),ttk1(end_z1),tt(nv),pp(nv),rh(km)
    5663. 

  5663.       real pp1(end_z1)
    5664. 

  5664.       real rho(nv),t1,t2,p1,p2,pk,r1,r2,b,rk
    5665. 

  5665. !
    5666. 

  5666. !  Wilis Island sounding (January)
    5667. 

  5667. !
    5668. 

  5668.       open(30,file='sound.d',form='formatted',status='old')
    5669. 

  5669.       do k=1,nv
    5670. 

  5670.       read(30,*) pp(k),tt(k),rho(k)
    5671. 

  5671.       enddo
    5672. 

  5672. !  2   format(1x,f7.1,7x,f7.2,8x,f4.1)
    5673. 

  5673.       close(30)
    5674. 

  5674. !
    5675. 

  5675.       do k=1,nv
    5676. 

  5676.       tt(k)=tt(k)+273.15
    5677. 

  5677.       enddo
    5678. 

  5678. !
    5679. 

  5679.       do k=1,km
    5680. 

  5680.       ppk(k)=sig1(k)*pse/100.0
    5681. 

  5681.       pp1(k)=sig(k)*pse/100.0
    5682. 

  5682.       enddo
    5683. 

  5683.       pp1(end_z1)=pse/100.0
    5684. 

  5684. !
    5685. 

  5685.       do k=1,km
    5686. 

  5686.       pk=ppk(k)
    5687. 

  5687. !
    5688. 

  5688.       do n1=1,nv-1
    5689. 

  5689.       if(pp(n1).le.pk.and.pp(n1+1).gt.pk) then
    5690. 

  5690.       t1=tt(n1)
    5691. 

  5691.       t2=tt(n1+1)
    5692. 

  5692.       p1=pp(n1)
    5693. 

  5693.       p2=pp(n1+1)
    5694. 

  5694.       endif
    5695. 

  5695.       enddo
    5696. 

  5696.       write(6,*) '     p1, p2=',p1,p2
    5697. 

  5697. !
    5698. 

  5698.       b=(t2-t1)/(p2-p1)
    5699. 

  5699.       ttk(k)=t1+b*(pk-p1)
    5700. 

  5700.       enddo
    5701. 

  5701. !
    5702. 

  5702.       do k=2,end_z1
    5703. 

  5703.       pk=pp1(k)
    5704. 

  5704. !
    5705. 

  5705.       do n1=1,nv-1
    5706. 

  5706.       if(pp(n1).le.pk.and.pp(n1+1).gt.pk) then
    5707. 

  5707.       t1=tt(n1)
    5708. 

  5708.       t2=tt(n1+1)
    5709. 

  5709.       p1=pp(n1)
    5710. 

  5710.      p2=pp(n1+1)
    5711. 

  5711.       endif
    5712. 

  5712.       enddo
    5713. 

  5713. !
    5714. 

  5714.       b=(t2-t1)/(p2-p1)
    5715. 

  5715.       ttk1(k)=t1+b*(pk-p1)
    5716. 

  5716.       enddo
    5717. 

  5717.       ttk1(1)=ttk(1)
    5718. 

  5718. !
    5719. 

  5719.       do k=1,km
    5720. 

  5720.       pk=ppk(k)
    5721. 

  5721. !
    5722. 

  5722.       do n1=1,nv-1
    5723. 

  5723.       if(pp(n1).le.pk.and.pp(n1+1).gt.pk) then
    5724. 

  5724.       r1=rho(n1)
    5725. 

  5725.       r2=rho(n1+1)
    5726. 

  5726.       p1=pp(n1)
    5727. 

  5727.       p2=pp(n1+1)
    5728. 

  5728.       endif
    5729. 

  5729.       enddo
    5730. 

  5730. !
    5731. 

  5731.       b=(r2-r1)/(p2-p1)
    5732. 

  5732.       rk=r1+b*(pk-p1)
    5733. 

  5733.       rh(k)=rk
    5734. 

  5734.       enddo
    5735. 

  5735. !
    5736. 

  5736.      open(23,file='pp.d',form='formatted')
    5737. 

  5737.       do k=1,end_z1
    5738. 

  5738.       write(23,3) k,sig(k),pp1(k),ttk1(k)-273.15
    5739. 

  5739.       enddo
    5740. 

  5740. !
    5741. 

  5741.       do k=1,km
    5742. 

  5742.       write(23,4) k,sig1(k),ppk(k),ttk(k)-273.15,rh(k)
    5743. 

  5743.       enddo
    5744. 

  5744.   3   format(2x,'k=',i2,',   sig=',f8.4,', p=',f8.3,', t=',f7.2)
    5745. 

  5745.   4   format(2x,'k=',i2,',   sig=',f8.4,', p=',f8.3,', t=',f7.2,', rh=', &
    5746. 

  5746.          f6.3)
    5747. 

  5747.       close(23)
    5748. 

  5748. !
    5749. 

  5749.       return
    5750. 

  5750.       end subroutine tem
    5751. 

  5751. 

  5752.       subroutine env(t,ps,f,lq,lp,ds,ty0,up1,km,end_z1)
    5753. 

  5753. !
    5754. 

  5754. !------------------------------------------------------------
    5755. 

  5755. !  This subroutine performs initialization for a zonal flow
    5756. 

  5756. !  using a nonlinear balance equation in sigma coordinate.
    5757. 

  5757. !------------------------------------------------------------
    5758. 

  5758.       implicit none
    5759. 

  5759.       include 'BALANCE_PARS.F'
    5760. 

  5760.       include 'BALANCE_COMS.F'
    5761. 

  5761.       integer i,j,k,lq,lp,km,end_z1,nnt
    5762. 

  5762.       real ds,ty0,forc1,forc2,forc3
    5763. 

  5763.       real alp(lp),tt(lp,end_z1),xx(lp),forc(lp)
    5764. 

  5764.       real alpy(lp),f(lp),t(lq,lp,km),ps(lq,lp)
    5765. 

  5765.       real tt2(2:km),up1(end_z1)
    5766. 

  5766.       real tk,t6,rh,rm,vm0,ts
    5767. 

  5767.       common /comp1/tk(kmx),t6(kmx1),rh(kmx),rm,vm0,ts
    5768. 

  5768. !
    5769. 

  5769.       it0=int(ty0+0.5)
    5770. 

  5770. !
    5771. 

  5771.       do 1 k=1,km
    5772. 

  5772.       do 1 i=1,lp
    5773. 

  5773.       do 1 j=1,lq
    5774. 

  5774.  1    t(j,i,k)=0.0
    5775. 

  5775. !
    5776. 

  5776.       do i=1,lp
    5777. 

  5777.       alpy(i)=-f(i)*up1(end_z1)/(rgas*ts)
    5778. 

  5778.       enddo
    5779. 

  5779.       alp(it0)=log(pse)
    5780. 

  5780.       do i=it0-1,1,-1
    5781. 

  5781.       alp(i)=alp(i+1)-0.5*(alpy(i)+alpy(i+1))*ds
    5782. 

  5782.       enddo
    5783. 

  5783.       do i=it0+1,lp
    5784. 

  5784.       alp(i)=alp(i-1)+0.5*(alpy(i)+alpy(i-1))*ds
    5785. 

  5785.       enddo
    5786. 

  5786. !
    5787. 

  5787.       do 2 j=1,lq
    5788. 

  5788.       do 2 i=1,lp
    5789. 

  5789.       ps(j,i)=exp(alp(i))
    5790. 

  5790.    2  continue
    5791. 

  5791. !
    5792. 

  5792.       nnt=0
    5793. 

  5793.    6  nnt=nnt+1
    5794. 

  5794. !
    5795. 

  5795.       do 8 i=1,lp
    5796. 

  5796.       do k=2,km
    5797. 

  5797.       tt2(k)=t(1,i,k-1)+(t(1,i,k)-t(1,i,k-1))*(sig(k)-sig1(k-1)) &
    5798. 

  5798.               /(sig1(k)-sig1(k-1))
    5799. 

  5799.       enddo
    5800. 

  5800.       do k=1,km
    5801. 

  5801.       if(k.eq.1) then
    5802. 

  5802.       tt(i,k)=(tt2(k+1)-t(1,i,k))/log(sig(k+1)/sig1(k))
    5803. 

  5803.       else if(k.eq.km) then
    5804. 

  5804.       tt(i,k)=(t(1,i,k)-tt2(k))/log(sig1(k)/sig(k))
    5805. 

  5805.       else
    5806. 

  5806.       tt(i,k)=(tt2(k+1)-tt2(k))/log(sig(k+1)/sig(k))
    5807. 

  5807.       endif
    5808. 

  5808.       enddo
    5809. 

  5809.    8  continue
    5810. 

  5810. !
    5811. 

  5811.       do 15 k=1,km
    5812. 

  5812. !
    5813. 

  5813.       do 9 i=1,lp
    5814. 

  5814.       forc1=tt(i,k)*alpy(i)
    5815. 

  5815.       if(k.eq.1) then
    5816. 

  5816.       forc2=f(i)*(up1(3)-up1(2))/(rgas*log(sig(3)/sig(2)))
    5817. 

  5817.       forc3=(t6(2)-tk(1))*alpy(i)/log(sig(2)/sig1(1))
    5818. 

  5818.       else
    5819. 

  5819.       forc2=f(i)*(up1(k+1)-up1(k))/(rgas*log(sig(k+1)/sig(k)))
    5820. 

  5820.       forc3=(t6(k+1)-t6(k))*alpy(i)/log(sig(k+1)/sig(k))
    5821. 

  5821.       endif
    5822. 

  5822.       forc(i)=forc1+forc2+forc3
    5823. 

  5823.   9   continue
    5824. 

  5824. !
    5825. 

  5825.       xx(it0)=0.0
    5826. 

  5826.       do i=it0-1,1,-1
    5827. 

  5827.       xx(i)=xx(i+1)-0.5*(forc(i)+forc(i+1))*ds
    5828. 

  5828.       enddo
    5829. 

  5829.       do i=it0+1,lp
    5830. 

  5830.       xx(i)=xx(i-1)+0.5*(forc(i)+forc(i-1))*ds
    5831. 

  5831.       enddo
    5832. 

  5832. !
    5833. 

  5833.       do i=1,lp
    5834. 

  5834.       do j=1,lq
    5835. 

  5835.       t(j,i,k)=xx(i)
    5836. 

  5836.       enddo
    5837. 

  5837.       enddo
    5838. 

  5838. !
    5839. 

  5839. !
    5840. 

  5840.   15  continue
    5841. 

  5841. !
    5842. 

  5842.       if(nnt.ne.6) goto 6
    5843. 

  5843. !
    5844. 

  5844.       return
    5845. 

  5845.       end subroutine env
    5846. 

  5846. !
    5847. 

  5847. !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    5848. 

  5848. 

  5849. !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    5850. 

  5850.       real function splin(x,a,b,c,d)
    5851. 

  5851.       implicit none
    5852. 

  5852.       real a,b,c,d
    5853. 

  5853.       real x(4)
    5854. 

  5854.       splin=(-a*x(1)+b*x(2)+c*x(3)-d*x(4))/81.0
    5855. 

  5855.       return
    5856. 

  5856.       end function splin
    5857. 

  5857. !
    5858. 

  5858. 

  5859. !------------------------------------------------------
    5860. 

  5860. !
    5861. 

  5861.       subroutine interpz(u,v,t,pp,qv,lq,lp,km)
    5862. 

  5862. !
    5863. 

  5863. !******************************************************
    5864. 

  5864.       implicit none
    5865. 

  5865.       include 'BALANCE_PARS.F'
    5866. 

  5866.       include 'BALANCE_COMS.F'
    5867. 

  5867.       integer i,j,k,lq,lp,km
    5868. 

  5868.       real ees,pa,ta,rqs,betk
    5869. 

  5869.       real u(lq,lp,km),v(lq,lp,km),qv(lq,lp,km),t(lq,lp,km)
    5870. 

  5870.       real tv(lq,lp,km),pp(lq,lp,km),pzz(lq,lp,km)
    5871. 

  5871. !***************************************************
    5872. 

  5872. !
    5873. 

  5873.       do i=1,lp
    5874. 

  5874.       do k=1,km
    5875. 

  5875.       do j=1,lq
    5876. 

  5876.       tv(j,i,k)=t(j,i,k)*(1.0+0.608*qv(j,i,k))
    5877. 

  5877.       enddo
    5878. 

  5878.       enddo
    5879. 

  5879.       enddo
    5880. 

  5880. !
    5881. 

  5881.       do i=1,lp
    5882. 

  5882.       do j=1,lq
    5883. 

  5883.       betk=(rgas/grv)*log(1.0/sig1(km))
    5884. 

  5884.       pzz(j,i,km)=betk*tv(j,i,km)
    5885. 

  5885.       enddo
    5886. 

  5886.       enddo
    5887. 

  5887.       do i=1,lp
    5888. 

  5888.       do k=km-1,1,-1
    5889. 

  5889.       do j=1,lq
    5890. 

  5890.       betk=0.5*(rgas/grv)*log(sig1(k+1)/sig1(k))
    5891. 

  5891.       pzz(j,i,k)=pzz(j,i,k+1)+betk*(tv(j,i,k)+tv(j,i,k+1))
    5892. 

  5892.       enddo
    5893. 

  5893.       enddo
    5894. 

  5894.       enddo
    5895. 

  5895. !
    5896. 

  5896.       do i=1,lp
    5897. 

  5897.       do k=1,km
    5898. 

  5898.       do j=1,lq
    5899. 

  5899.       pa=pp(j,i,k)
    5900. 

  5900.       ta=t(j,i,k)
    5901. 

  5901.       ees=611.2*exp(cs2*(ta-cs3)/(ta-cs4))
    5902. 

  5902.       rqs=0.622*ees/(pa-ees)
    5903. 

  5903.       qv(j,i,k)=qv(j,i,k)/rqs
    5904. 

  5904.       enddo
    5905. 

  5905.       enddo
    5906. 

  5906.       enddo
    5907. 

  5907. !
    5908. 

  5908.       call interps(u,pzz,poz,lq,lp,km)
    5909. 

  5909.       call interps(v,pzz,poz,lq,lp,km)
    5910. 

  5910.       call interps(t,pzz,poz,lq,lp,km)
    5911. 

  5911.       call interps(pp,pzz,poz,lq,lp,km)
    5912. 

  5912.      call interps(qv,pzz,poz,lq,lp,km)
    5913. 

  5913. !
    5914. 

  5914.       do i=1,lp
    5915. 

  5915.       do k=1,km
    5916. 

  5916.       do j=1,lq
    5917. 

  5917.       pa=pp(j,i,k)
    5918. 

  5918.       ta=t(j,i,k)
    5919. 

  5919.       ees=611.2*exp(cs2*(ta-cs3)/(ta-cs4))
    5920. 

  5920.       rqs=0.622*ees/(pa-ees)
    5921. 

  5921.       qv(j,i,k)=qv(j,i,k)*rqs
    5922. 

  5922.       enddo
    5923. 

  5923.       enddo
    5924. 

  5924.       enddo
    5925. 

  5925. !
    5926. 

  5926.       return
    5927. 

  5927.       end subroutine interpz
    5928. 

  5928. !
    5929. 

  5929. !-------------------------------------------------
    5930. 

  5930. !  this subroutine performs vertical interpotation
    5931. 

  5931. !-------------------------------------------------
    5932. 

  5932. !
    5933. 

  5933.       subroutine interps(as,zz,poz,lq,lp,km)
    5934. 

  5934. !
    5935. 

  5935. !-------------------------------------------------
    5936. 

  5936.      implicit none
    5937. 

  5937.       integer i,j,k,lq,lp,km,n1,nn
    5938. 

  5938.       real a1,a2,sg,sg1,sg2,b
    5939. 

  5939.       real as(lq,lp,km),poz(km),zz(lq,lp,km),wk(lq,lp,km)
    5940. 

  5940. !
    5941. 

  5941.       do 100 i=1,lp
    5942. 

  5942.       do 100 j=1,lq
    5943. 

  5943. !
    5944. 

  5944.       do 100 k=1,km
    5945. 

  5945.       sg=poz(k)
    5946. 

  5946.       if(sg.le.zz(j,i,km)) then
    5947. 

  5947.       n1=km-1
    5948. 

  5948.       else if(sg.gt.zz(j,i,1)) then
    5949. 

  5949.       n1=1
    5950. 

  5950.       else
    5951. 

  5951.       do nn=1,km-1
    5952. 

  5952.       if(sg.gt.zz(j,i,nn+1).and.sg.le.zz(j,i,nn)) then
    5953. 

  5953.       n1=nn
    5954. 

  5954.       goto 20
    5955. 

  5955.       endif
    5956. 

  5956.       enddo
    5957. 

  5957.   20  continue
    5958. 

  5958.       endif
    5959. 

  5959.       a1=as(j,i,n1+1)
    5960. 

  5960.       a2=as(j,i,n1)
    5961. 

  5961.       sg1=zz(j,i,n1+1)
    5962. 

  5962.       sg2=zz(j,i,n1)
    5963. 

  5963.     sg2=zz(j,i,n1)
    5964. 

  5964.       b=(a2-a1)/(sg2-sg1)
    5965. 

  5965.       wk(j,i,k)=a1+b*(sg-sg1)
    5966. 

  5966. !
    5967. 

  5967.   100 continue
    5968. 

  5968. !
    5969. 

  5969.       do 200 i=1,lp
    5970. 

  5970.       do 200 k=1,km
    5971. 

  5971.       do 200 j=1,lq
    5972. 

  5972.       as(j,i,k)=wk(j,i,k)
    5973. 

  5973.   200 continue
    5974. 

  5974. !
    5975. 

  5975.       return
    5976. 

  5976.       end subroutine interps
    5977. 

  5977. 

  5978. 

  5979. 

  5980. #ifdef HWRF
    5981. 

  5981. ! compute earth lat-lons for before interpolations. This is gopal's doing for ocean coupling
    5982. 

  5982. !============================================================================================
    5983. 

  5983. 

  5984. SUBROUTINE EARTH_LATLON_hwrf ( HLAT,HLON,VLAT,VLON,     & !Earth lat,lon at H and V points
    5985. 

  5985.                           DLMD1,DPHD1,WBD1,SBD1,   & !input res,west & south boundaries,
    5986. 

  5986.                           CENTRAL_LAT,CENTRAL_LON, & ! central lat,lon, all in degrees
    5987. 

  5987.                           IDS,IDE,JDS,JDE,KDS,KDE, &
    5988. 

  5988.                           IMS,IME,JMS,JME,KMS,KME, &
    5989. 

  5989.                           ITS,ITE,JTS,JTE,KTS,KTE  )
    5990. 

  5990. !============================================================================
    5991. 

  5991. !
    5992. 

  5992.  IMPLICIT NONE
    5993. 

  5993.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    5994. 

  5994.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    5995. 

  5995.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    5996. 

  5996.  REAL,       INTENT(IN   )                            :: DLMD1,DPHD1,WBD1,SBD1
    5997. 

  5997.  REAL,       INTENT(IN   )                            :: CENTRAL_LAT,CENTRAL_LON
    5998. 

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

  5999. 

  6000. ! local
    6001. 

  6001. 

  6002.  INTEGER,PARAMETER                           :: KNUM=SELECTED_REAL_KIND(13)
    6003. 

  6003.  INTEGER                                     :: I,J
    6004. 

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

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

  6006.  REAL(KIND=KNUM)                             :: STPH,CTPH,STPV,CTPV,PI_2
    6007. 

  6007.  REAL(KIND=KNUM)                             :: SPHH,CLMH,FACTH,SPHV,CLMV,FACTV
    6008. 

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

  6009. !-------------------------------------------------------------------------
    6010. 

  6010. 

  6011. !
    6012. 

  6012.       PI_2 = ACOS(0.)
    6013. 

  6013.       DTR  = PI_2/90.
    6014. 

  6014.       WB   = WBD1 * DTR                 ! WB:   western boundary in radians
    6015. 

  6015.       SB   = SBD1 * DTR                 ! SB:   southern boundary in radians
    6016. 

  6016.       DLM  = DLMD1 * DTR                ! DLM:  dlamda in radians
    6017. 

  6017.       DPH  = DPHD1 * DTR                ! DPH:  dphi   in radians
    6018. 

  6018.       TDLM = DLM + DLM                  ! TDLM: 2.0*dlamda
    6019. 

  6019.       TDPH = DPH + DPH                  ! TDPH: 2.0*DPH
    6020. 

  6020. 

  6021. !     For earth lat lon only
    6022. 

  6022. 

  6023.       TPH0  = CENTRAL_LAT*DTR                ! TPH0: central lat in radians
    6024. 

  6024.       STPH0 = SIN(TPH0)
    6025. 

  6025.       CTPH0 = COS(TPH0)
    6026. 

  6026. 

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

  6028. !                                               !   \.H  starting points along j
    6029. 

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

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

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

  6032.          TPHV = TPHH                            !   TPHV (rotated lons at V points) are simple trans.
    6033. 

  6033.          STPH = SIN(TPHH)
    6034. 

  6034.          CTPH = COS(TPHH)
    6035. 

  6035.          STPV = SIN(TPHV)
    6036. 

  6036.          CTPV = COS(TPHV)
    6037. 

  6037. 

  6038.                                                               !   .H
    6039. 

  6039.          DO I = ITS,MIN(ITE,IDE) !-1)                         !  /
    6040. 

  6040.            TLMH = TLMH0 + I*TDLM                              !  \.H   .U   .H
    6041. 

  6041. !                                                             !H./ ----><----
    6042. 

  6042.            SPHH = CTPH0 * STPH + STPH0 * CTPH * COS(TLMH)     !     DLM + DLM
    6043. 

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

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

  6045.                 - TAN(GLATH(I,J))*TAN(TPH0)
    6046. 

  6046.            IF(CLMH .GT. 1.) CLMH = 1.0
    6047. 

  6047.            IF(CLMH .LT. -1.) CLMH = -1.0
    6048. 

  6048.            FACTH = 1.
    6049. 

  6049.            IF(TLMH .GT. 0.) FACTH = -1.
    6050. 

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

  6051. 

  6052.          ENDDO
    6053. 

  6053. 

  6054.          DO I = ITS,MIN(ITE,IDE) !-1)
    6055. 

  6055.            TLMV = TLMV0 + I*TDLM
    6056. 

  6056.            SPHV = CTPH0 * STPV + STPH0 * CTPV * COS(TLMV)
    6057. 

  6057.            GLATV(I,J) = ASIN(SPHV)
    6058. 

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

  6059.                 - TAN(GLATV(I,J))*TAN(TPH0)
    6060. 

  6060.            IF(CLMV .GT. 1.) CLMV = 1.
    6061. 

  6061.            IF(CLMV .LT. -1.) CLMV = -1.
    6062. 

  6062.            FACTV = 1.
    6063. 

  6063.            IF(TLMV .GT. 0.) FACTV = -1.
    6064. 

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

  6065. 

  6066.          ENDDO
    6067. 

  6067. 

  6068.       ENDDO
    6069. 

  6069. 

  6070. !     Conversion to degrees (may not be required, eventually)
    6071. 

  6071. 

  6072.       DO J = JTS, MIN(JTE,JDE)  !-1)
    6073. 

  6073.        DO I = ITS, MIN(ITE,IDE) !-1)
    6074. 

  6074.           HLAT(I,J) = GLATH(I,J) / DTR
    6075. 

  6075.           HLON(I,J)= -GLONH(I,J)/DTR
    6076. 

  6076.           IF(HLON(I,J) .GT. 180.) HLON(I,J) = HLON(I,J)  - 360.
    6077. 

  6077.           IF(HLON(I,J) .LT. -180.) HLON(I,J) = HLON(I,J) + 360.
    6078. 

  6078. !
    6079. 

  6079.           VLAT(I,J) = GLATV(I,J) / DTR
    6080. 

  6080.           VLON(I,J) = -GLONV(I,J) / DTR
    6081. 

  6081.           IF(VLON(I,J) .GT. 180.) VLON(I,J) = VLON(I,J)  - 360.
    6082. 

  6082.           IF(VLON(I,J) .LT. -180.) VLON(I,J) = VLON(I,J) + 360.
    6083. 

  6083. 

  6084.        ENDDO
    6085. 

  6085.       ENDDO
    6086. 

  6086. 

  6087. END SUBROUTINE EARTH_LATLON_hwrf
    6088. 

  6088. 

  6089.   SUBROUTINE G2T2H_hwrf( SM,HRES_SM,                          & ! output grid index and weights
    6090. 

  6090.                     HLAT,HLON,                           & ! target (nest) input lat lon in degrees
    6091. 

  6091.                     DLMD1,DPHD1,WBD1,SBD1,               & ! parent res, west and south boundaries
    6092. 

  6092.                     CENTRAL_LAT,CENTRAL_LON,             & ! parent central lat,lon, all in degrees
    6093. 

  6093.                     P_IDE,P_JDE,P_IMS,P_IME,P_JMS,P_JME, & ! parent imax and jmax
    6094. 

  6094.                     IDS,IDE,JDS,JDE,KDS,KDE,             & ! target (nest) dIMEnsions
    6095. 

  6095.                     IMS,IME,JMS,JME,KMS,KME,             &
    6096. 

  6096.                     ITS,ITE,JTS,JTE,KTS,KTE              )
    6097. 

  6097. 

  6098. !
    6099. 

  6099. !***  Tom Black   - Initial Version
    6100. 

  6100. !***  Gopal       - Revised Version for WRF (includes coincident grid points)
    6101. 

  6101. !***
    6102. 

  6102. !***  GIVEN PARENT CENTRAL LAT-LONS, RESOLUTION AND WESTERN AND SOUTHERN BOUNDARY,
    6103. 

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

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

  6105. !***  h POINTS OF THE NESTED DOMAIN
    6106. 

  6106. !
    6107. 

  6107. !============================================================================
    6108. 

  6108. !
    6109. 

  6109.  IMPLICIT NONE
    6110. 

  6110.  INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
    6111. 

  6111.  INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
    6112. 

  6112.  INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
    6113. 

  6113.  INTEGER,    INTENT(IN   )                            :: P_IDE,P_JDE,P_IMS,P_IME,P_JMS,P_JME
    6114. 

  6114.  REAL,       INTENT(IN   )                            :: DLMD1,DPHD1,WBD1,SBD1
    6115. 

  6115.  REAL,       INTENT(IN   )                            :: CENTRAL_LAT,CENTRAL_LON
    6116. 

  6116.  REAL,    DIMENSION(P_IMS:P_IME,P_JMS:P_JME), INTENT(IN)   :: SM
    6117. 

  6117.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(IN)   :: HLAT,HLON
    6118. 

  6118.  REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HRES_SM
    6119. 

  6119. 

  6120. ! local
    6121. 

  6121. 

  6122.  INTEGER,PARAMETER :: KNUM=SELECTED_REAL_KIND(13)
    6123. 

  6123.  INTEGER           :: IMT,JMT,N2R,MK,K,I,J,DSLP0,DSLOPE,N
    6124. 

  6124.  INTEGER           :: NROW,NCOL,KROWS
    6125. 

  6125.  REAL(KIND=KNUM)   :: X,Y,Z,TLAT,TLON
    6126. 

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

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

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

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

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

  6131.  REAL(KIND=KNUM)   :: DTEMP
    6132. 

  6132.  REAL   , DIMENSION(IMS:IME,JMS:JME)    :: TLATHX,TLONHX
    6133. 

  6133.  INTEGER, DIMENSION(IMS:IME,JMS:JME)    :: KOUTB
    6134. 

  6134.  REAL     SUM,AMAXVAL
    6135. 

  6135.  REAL,    DIMENSION (4, ims:ime, jms:jme ) :: NBWGT
    6136. 

  6136.  LOGICAL  FLIP
    6137. 

  6137.  REAL,    DIMENSION(IMS:IME,JMS:JME)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
    6138. 

  6138.  INTEGER, DIMENSION(IMS:IME,JMS:JME)  :: IIH,JJH
    6139. 

  6139. !-------------------------------------------------------------------------------
    6140. 

  6140. 

  6141.   IMT=2*P_IDE-2             ! parent i dIMEnsions
    6142. 

  6142.   JMT=P_JDE/2               ! parent j dIMEnsions
    6143. 

  6143.   PI_2=ACOS(0.)
    6144. 

  6144.   D2R=PI_2/90.
    6145. 

  6145.   R2D=1./D2R
    6146. 

  6146.   DPH=DPHD1*D2R
    6147. 

  6147.   DLM=DLMD1*D2R
    6148. 

  6148.   TPH0= CENTRAL_LAT*D2R
    6149. 

  6149.   TLM0=-CENTRAL_LON*D2R        ! NOTE THE MINUS HERE
    6150. 

  6150.   WB=WBD1*D2R                   ! CONVERT NESTED GRID H POINTS FROM GEODETIC
    6151. 

  6151.   SB=SBD1*D2R
    6152. 

  6152.   SLP0=DPHD1/DLMD1
    6153. 

  6153.   DSLP0=NINT(R2D*ATAN(SLP0))
    6154. 

  6154.   DS1=SQRT(DPH*DPH+DLM*DLM)    ! Q
    6155. 

  6155.   AN1=ASIN(DLM/DS1)
    6156. 

  6156.   AN2=ASIN(DPH/DS1)
    6157. 

  6157. 

  6158. 

  6159.   DO J =  JTS,MIN(JTE,JDE)  !-1)
    6160. 

  6160.     DO I = ITS,MIN(ITE,IDE) !-1)
    6161. 

  6161. 

  6162. !***
    6163. 

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

  6164. !***  DETERMINE THE INDICES IN TERMS OF THE PARENT DOMAIN. FIRST
    6165. 

  6165. !***  CONVERT NESTED GRID h POINTS FROM GEODETIC TO TRANSFORMED
    6166. 

  6166. !***  COORDINATE ON THE PARENT GRID
    6167. 

  6167. !
    6168. 

  6168. 

  6169.       GLAT=HLAT(I,J)*D2R
    6170. 

  6170.       GLON= (360. - HLON(I,J))*D2R
    6171. 

  6171.       X=COS(TPH0)*COS(GLAT)*COS(GLON-TLM0)+SIN(TPH0)*SIN(GLAT)
    6172. 

  6172.       Y=-COS(GLAT)*SIN(GLON-TLM0)
    6173. 

  6173.       Z=COS(TPH0)*SIN(GLAT)-SIN(TPH0)*COS(GLAT)*COS(GLON-TLM0)
    6174. 

  6174.       TLAT=R2D*ATAN(Z/SQRT(X*X+Y*Y))
    6175. 

  6175.       TLON=R2D*ATAN(Y/X)
    6176. 

  6176. 

  6177. !    
    6178. 

  6178.       ROW=TLAT/DPHD1+JMT         ! JMT IS THE CENTRAL ROW OF THE PARENT DOMAIN
    6179. 

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

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

  6181.       NCOL=INT(COL + 0.001)
    6182. 

  6182.       TLAT=TLAT*D2R
    6183. 

  6183.       TLON=TLON*D2R
    6184. 

  6184. 

  6185. !      WRITE(60,*)'============================================================'
    6186. 

  6186. !      WRITE(60,*)'              ','i=',i,'j=',j
    6187. 

  6187. !*** 
    6188. 

  6188. !***
    6189. 

  6189. !***  FIRST CONSIDER THE SITUATION WHERE THE POINT h IS AT
    6190. 

  6190. !***
    6191. 

  6191. !***              V      H
    6192. 

  6192. !***
    6193. 

  6193. !***
    6194. 

  6194. !***                 h
    6195. 

  6195. !***              H      V
    6196. 

  6196. !***
    6197. 

  6197. !***  THEN LOCATE THE NEAREST H POINT ON THE PARENT GRID
    6198. 

  6198. !***
    6199. 

  6199.       IF(MOD(NROW,2).EQ.1.AND.MOD(NCOL,2).EQ.1.OR.     &
    6200. 

  6200.          MOD(NROW,2).EQ.0.AND.MOD(NCOL,2).EQ.0)THEN
    6201. 

  6201.            TLAT1=(NROW-JMT)*DPH
    6202. 

  6202.            TLAT2=TLAT1+DPH
    6203. 

  6203.            TLON1=(NCOL-(P_IDE-1))*DLM
    6204. 

  6204.            TLON2=TLON1+DLM
    6205. 

  6205.            DLM1=TLON-TLON1
    6206. 

  6206.            DLM2=TLON-TLON2
    6207. 

  6207. !           D1=ACOS(COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
    6208. 

  6208. !           D2=ACOS(COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
    6209. 

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

  6210.            D1=ACOS(DTEMP)
    6211. 

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

  6212.            D2=ACOS(DTEMP)
    6213. 

  6213.             IF(D1.GT.D2)THEN
    6214. 

  6214.              NROW=NROW+1                    ! FIND THE NEAREST H ROW
    6215. 

  6215.              NCOL=NCOL+1                    ! FIND THE NEAREST H COLUMN
    6216. 

  6216.             ENDIF
    6217. 

  6217. !            WRITE(60,*)'NEAREST PARENT IS:','col=',COL,'row=',ROW,'ncol=',NCOL,'nrow=',NROW
    6218. 

  6218.       ELSE
    6219. 

  6219. !***
    6220. 

  6220. !***  NOW CONSIDER THE SITUATION WHERE THE POINT h IS AT
    6221. 

  6221. !***
    6222. 

  6222. !***              H      V
    6223. 

  6223. !***
    6224. 

  6224. !***
    6225. 

  6225. !***                 h
    6226. 

  6226. !***              V      H
    6227. 

  6227. !***
    6228. 

  6228. !***  THEN LOCATE THE NEAREST H POINT ON THE PARENT GRID
    6229. 

  6229. !***
    6230. 

  6230. !***
    6231. 

  6231.            TLAT1=(NROW+1-JMT)*DPH
    6232. 

  6232.            TLAT2=TLAT1-DPH
    6233. 

  6233.            TLON1=(NCOL-(P_IDE-1))*DLM
    6234. 

  6234.            TLON2=TLON1+DLM
    6235. 

  6235.            DLM1=TLON-TLON1
    6236. 

  6236.            DLM2=TLON-TLON2
    6237. 

  6237. !           D1=ACOS(COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
    6238. 

  6238. !           D2=ACOS(COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
    6239. 

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

  6240.            D1=ACOS(DTEMP)
    6241. 

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

  6242.            D2=ACOS(DTEMP)
    6243. 

  6243.              IF(D1.LT.D2)THEN
    6244. 

  6244.               NROW=NROW+1                    ! FIND THE NEAREST H ROW
    6245. 

  6245.              ELSE
    6246. 

  6246.               NCOL=NCOL+1                    ! FIND THE NEAREST H COLUMN
    6247. 

  6247.              ENDIF
    6248. 

  6248. !             WRITE(60,*)'NEAREST PARENT IS:','col=',COL,'row=',ROW,'ncol=',NCOL,'nrow=',NROW
    6249. 

  6249.       ENDIF
    6250. 

  6250. 

  6251.       KROWS=((NROW-1)/2)*IMT
    6252. 

  6252.       IF(MOD(NROW,2).EQ.1)THEN
    6253. 

  6253.         K=KROWS+(NCOL+1)/2
    6254. 

  6254.       ELSE
    6255. 

  6255.         K=KROWS+P_IDE-1+NCOL/2
    6256. 

  6256.       ENDIF
    6257. 

  6257. 

  6258. !***
    6259. 

  6259. !***  WE NOW KNOW THAT THE INNER GRID POINT IN QUESTION IS
    6260. 

  6260. !***  NEAREST TO THE CENTER K AS SEEN BELOW.  WE MUST FIND
    6261. 

  6261. !***  WHICH OF THE FOUR H-BOXES (OF WHICH THIS H POINT IS
    6262. 

  6262. !***  A VERTEX) SURROUNDS THE INNER GRID h POINT IN QUESTION.
    6263. 

  6263. !***
    6264. 

  6264. !**
    6265. 

  6265. !***                  H
    6266. 

  6266. !***
    6267. 

  6267. !***
    6268. 

  6268. !***
    6269. 

  6269. !***            H     V     H
    6270. 

  6270. !***
    6271. 

  6271. !***
    6272. 

  6272. !***               h
    6273. 

  6273. !***      H     V     H     V     H
    6274. 

  6274. !***
    6275. 

  6275. !***
    6276. 

  6276. !***
    6277. 

  6277. !***            H     V     H
    6278. 

  6278. !***
    6279. 

  6279. !***
    6280. 

  6280. !***
    6281. 

  6281. !***                  H
    6282. 

  6282. !***
    6283. 

  6283. !***
    6284. 

  6284. !***  FIND THE SLOPE OF THE LINE CONNECTING h AND THE CENTER H.
    6285. 

  6285. !***
    6286. 

  6286.     N2R=K/IMT
    6287. 

  6287.     MK=MOD(K,IMT)
    6288. 

  6288. !
    6289. 

  6289.     IF(MK.EQ.0)THEN
    6290. 

  6290.       TLATHC=SB+(2*N2R-1)*DPH
    6291. 

  6291.     ELSE
    6292. 

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

  6293.     ENDIF
    6294. 

  6294. !
    6295. 

  6295.     IF(MK.LE.(P_IDE-1))THEN
    6296. 

  6296.       TLONHC=WB+2*(MK-1)*DLM
    6297. 

  6297.     ELSE
    6298. 

  6298.       TLONHC=WB+(2*(MK-(P_IDE-1))-1)*DLM
    6299. 

  6299.     ENDIF
    6300. 

  6300.  
    6301. 

  6301. !
    6302. 

  6302. !***  EXECUTE CAUTION IF YOU NEED TO CHANGE THESE CONDITIONS. SINCE WE ARE
    6303. 

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

  6304. !***  CAREFUL HERE
    6305. 

  6305. !
    6306. 

  6306. 

  6307.     IF(ABS(TLON-TLONHC) .LE. 1.E-4)TLONHC=TLON
    6308. 

  6308.     IF(ABS(TLAT-TLATHC) .LE. 1.E-4)TLATHC=TLAT
    6309. 

  6309.     DENOM=(TLON-TLONHC)
    6310. 

  6310. !
    6311. 

  6311. !***
    6312. 

  6312. !***STORE THE LOCATION OF THE WESTERNMOST VERTEX OF THE H-BOX ON
    6313. 

  6313. !***THE OUTER GRID THAT SURROUNDS THE h POINT ON THE INNER GRID.
    6314. 

  6314. !***
    6315. 

  6315. !*** COINCIDENT CONDITIONS
    6316. 

  6316. 

  6317.     IF(DENOM.EQ.0.0)THEN
    6318. 

  6318. 

  6319.       IF(TLATHC.EQ.TLAT)THEN
    6320. 

  6320.         KOUTB(I,J)=K
    6321. 

  6321.         IIH(I,J) = NCOL
    6322. 

  6322.         JJH(I,J) = NROW
    6323. 

  6323.         TLATHX(I,J)=TLATHC
    6324. 

  6324.         TLONHX(I,J)=TLONHC
    6325. 

  6325.         HBWGT1(I,J)=1.0
    6326. 

  6326.         HBWGT2(I,J)=0.0
    6327. 

  6327.         HBWGT3(I,J)=0.0
    6328. 

  6328.         HBWGT4(I,J)=0.0
    6329. 

  6329. !        WRITE(60,*)'TRIVIAL SOLUTION'
    6330. 

  6330.       ELSE                                      ! SAME LONGITUDE BUT DIFFERENT LATS
    6331. 

  6331. !
    6332. 

  6332.          IF(TLATHC .GT. TLAT)THEN      ! NESTED POINT SOUTH OF PARENT
    6333. 

  6333.           KOUTB(I,J)=K-(P_IDE-1)
    6334. 

  6334.           IIH(I,J) = NCOL-1
    6335. 

  6335.           JJH(I,J) = NROW-1
    6336. 

  6336.           TLATHX(I,J)=TLATHC-DPH
    6337. 

  6337.           TLONHX(I,J)=TLONHC-DLM
    6338. 

  6338. !          WRITE(60,*)'VANISHING SLOPE, -ve: TLATHC-DPH, TLONHC-DLM'
    6339. 

  6339.          ELSE                                   ! NESTED POINT NORTH OF PARENT
    6340. 

  6340.           KOUTB(I,J)=K+(P_IDE-1)-1
    6341. 

  6341.           IIH(I,J) = NCOL-1
    6342. 

  6342.           JJH(I,J) = NROW+1
    6343. 

  6343.           TLATHX(I,J)=TLATHC+DPH
    6344. 

  6344.           TLONHX(I,J)=TLONHC-DLM
    6345. 

  6345. !          WRITE(60,*)'VANISHING SLOPE, +ve: TLATHC+DPH, TLONHC-DLM'
    6346. 

  6346.          ENDIF
    6347. 

  6347. !***
    6348. 

  6348. !***
    6349. 

  6349. !***                  4
    6350. 

  6350. !***
    6351. 

  6351. !***                  h
    6352. 

  6352. !***             1         2
    6353. 

  6353. !***
    6354. 

  6354. !***                  3
    6355. 

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

  6356. 

  6357.        TLATO=TLATHX(I,J)
    6358. 

  6358.        TLONO=TLONHX(I,J)
    6359. 

  6359.        DLM1=TLON-TLONO
    6360. 

  6360.        DLA1=TLAT-TLATO                                               ! Q
    6361. 

  6361. !      DL1=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM1)+SIN(TLAT)*SIN(TLATO)) ! Q
    6362. 

  6362.        DL1=SQRT(DLM1*DLM1+DLA1*DLA1)                                 ! Q
    6363. 

  6363. !
    6364. 

  6364.        TLATO=TLATHX(I,J)
    6365. 

  6365.        TLONO=TLONHX(I,J)+2.*DLM
    6366. 

  6366.        DLM2=TLON-TLONO
    6367. 

  6367.        DLA2=TLAT-TLATO                                               ! Q
    6368. 

  6368. !      DL2=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM2)+SIN(TLAT)*SIN(TLATO)) ! Q
    6369. 

  6369.        DL2=SQRT(DLM2*DLM2+DLA2*DLA2)                                 ! Q
    6370. 

  6370. !
    6371. 

  6371.        TLATO=TLATHX(I,J)-DPH
    6372. 

  6372.        TLONO=TLONHX(I,J)+DLM
    6373. 

  6373.        DLM3=TLON-TLONO
    6374. 

  6374.        DLA3=TLAT-TLATO                                               ! Q
    6375. 

  6375. !      DL3=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM3)+SIN(TLAT)*SIN(TLATO)) ! Q
    6376. 

  6376.        DL3=SQRT(DLM3*DLM3+DLA3*DLA3)                                 ! Q
    6377. 

  6377. 

  6378.        TLATO=TLATHX(I,J)+DPH
    6379. 

  6379.        TLONO=TLONHX(I,J)+DLM
    6380. 

  6380.        DLM4=TLON-TLONO
    6381. 

  6381.        DLA4=TLAT-TLATO                                               ! Q
    6382. 

  6382. !      DL4=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM4)+SIN(TLAT)*SIN(TLATO)) ! Q
    6383. 

  6383.        DL4=SQRT(DLM4*DLM4+DLA4*DLA4)                                 ! Q
    6384. 

  6384. 

  6385. 

  6386. !      THE BILINEAR WEIGHTS
    6387. 

  6387. !***
    6388. 

  6388. !***
    6389. 

  6389.        AN3=ATAN2(DLA1,DLM1)                                          ! Q
    6390. 

  6390.        R1=DL1*SIN(AN2-AN3)/SIN(2.*AN1)
    6391. 

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

  6392.        R1=R1/DS1
    6393. 

  6393.        S1=S1/DS1
    6394. 

  6394.        DL1I=(1.-R1)*(1.-S1)
    6395. 

  6395.        DL2I=R1*S1
    6396. 

  6396.        DL3I=R1*(1.-S1)
    6397. 

  6397.        DL4I=(1.-R1)*S1
    6398. 

  6398. !
    6399. 

  6399.        HBWGT1(I,J)=DL1I
    6400. 

  6400.        HBWGT2(I,J)=DL2I
    6401. 

  6401.        HBWGT3(I,J)=DL3I
    6402. 

  6402.        HBWGT4(I,J)=DL4I
    6403. 

  6403. !
    6404. 

  6404.       ENDIF
    6405. 

  6405. 

  6406.     ELSE
    6407. 

  6407. !
    6408. 

  6408. !*** NON-COINCIDENT POINTS
    6409. 

  6409. !
    6410. 

  6410.       SLOPE=(TLAT-TLATHC)/DENOM
    6411. 

  6411.       DSLOPE=NINT(R2D*ATAN(SLOPE))
    6412. 

  6412. 

  6413.       IF(DSLOPE.LE.DSLP0.AND.DSLOPE.GE.-DSLP0)THEN
    6414. 

  6414.         IF(TLON.GT.TLONHC)THEN
    6415. 

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

  6416.           KOUTB(I,J)=K
    6417. 

  6417.           IIH(I,J) = NCOL
    6418. 

  6418.           JJH(I,J) = NROW
    6419. 

  6419.           TLATHX(I,J)=TLATHC
    6420. 

  6420.           TLONHX(I,J)=TLONHC
    6421. 

  6421. !          WRITE(60,*)'HERE WE GO1: TLATHC, TLONHC'
    6422. 

  6422.         ELSE
    6423. 

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

  6424.           KOUTB(I,J)=K-1
    6425. 

  6425.           IIH(I,J) = NCOL-2
    6426. 

  6426.           JJH(I,J) = NROW
    6427. 

  6427.           TLATHX(I,J)=TLATHC
    6428. 

  6428.           TLONHX(I,J)=TLONHC -2.*DLM
    6429. 

  6429. !          WRITE(60,*)'HERE WE GO2: TLATHC, TLONHC -2.*DLM'
    6430. 

  6430.         ENDIF
    6431. 

  6431. 

  6432. !
    6433. 

  6433.       ELSEIF(DSLOPE.GT.DSLP0)THEN
    6434. 

  6434.         IF(TLON.GT.TLONHC)THEN
    6435. 

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

  6436.           KOUTB(I,J)=K+(P_IDE-1)-1
    6437. 

  6437.           IIH(I,J) = NCOL-1
    6438. 

  6438.           JJH(I,J) = NROW+1
    6439. 

  6439.           TLATHX(I,J)=TLATHC+DPH
    6440. 

  6440.           TLONHX(I,J)=TLONHC-DLM
    6441. 

  6441. !          WRITE(60,*)'HERE WE GO3:  TLATHC+DPH, TLONHC-DLM'
    6442. 

  6442.         ELSE
    6443. 

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

  6444.           KOUTB(I,J)=K-(P_IDE-1)
    6445. 

  6445.           IIH(I,J) = NCOL-1
    6446. 

  6446.           JJH(I,J) = NROW-1
    6447. 

  6447.           TLATHX(I,J)=TLATHC-DPH
    6448. 

  6448.           TLONHX(I,J)=TLONHC-DLM
    6449. 

  6449. !          WRITE(60,*)'HERE WE GO4:  TLATHC-DPH, TLONHC-DLM'
    6450. 

  6450.         ENDIF
    6451. 

  6451. 

  6452. !
    6453. 

  6453.       ELSEIF(DSLOPE.LT.-DSLP0)THEN
    6454. 

  6454.         IF(TLON.GT.TLONHC)THEN
    6455. 

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

  6456.           KOUTB(I,J)=K-(P_IDE-1)
    6457. 

  6457.           IIH(I,J) = NCOL-1
    6458. 

  6458.           JJH(I,J) = NROW-1
    6459. 

  6459.           TLATHX(I,J)=TLATHC-DPH
    6460. 

  6460.           TLONHX(I,J)=TLONHC-DLM
    6461. 

  6461. !          WRITE(60,*)'HERE WE GO5:  TLATHC-DPH, TLONHC-DLM'
    6462. 

  6462.         ELSE
    6463. 

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

  6464.           KOUTB(I,J)=K+(P_IDE-1)-1
    6465. 

  6465.           IIH(I,J) = NCOL-1
    6466. 

  6466.           JJH(I,J) = NROW+1
    6467. 

  6467.           TLATHX(I,J)=TLATHC+DPH
    6468. 

  6468.           TLONHX(I,J)=TLONHC-DLM
    6469. 

  6469. !          WRITE(60,*)'HERE WE GO6: TLATHC+DPH,  TLONHC-DLM'
    6470. 

  6470.         ENDIF
    6471. 

  6471.       ENDIF
    6472. 

  6472. 

  6473. !
    6474. 

  6474. !***  NOW WE WILL MOVE AS FOLLOWS:
    6475. 

  6475. !***
    6476. 

  6476. !***
    6477. 

  6477. !***                      4
    6478. 

  6478. !***
    6479. 

  6479. !***
    6480. 

  6480. !*** 
    6481. 

  6481. !***                   h
    6482. 

  6482. !***             1                 2
    6483. 

  6483. !***
    6484. 

  6484. !***
    6485. 

  6485. !***
    6486. 

  6486. !***
    6487. 

  6487. !***                      3
    6488. 

  6488. !***
    6489. 

  6489. !***
    6490. 

  6490. !***
    6491. 

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

  6492. 

  6493.       TLATO=TLATHX(I,J)
    6494. 

  6494.       TLONO=TLONHX(I,J)
    6495. 

  6495.       DLM1=TLON-TLONO
    6496. 

  6496.       DLA1=TLAT-TLATO                                               ! Q
    6497. 

  6497. !     DL1=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM1)+SIN(TLAT)*SIN(TLATO)) ! Q
    6498. 

  6498.       DL1=SQRT(DLM1*DLM1+DLA1*DLA1)                                 ! Q
    6499. 

  6499. !
    6500. 

  6500.       TLATO=TLATHX(I,J)                                             ! redundant computations
    6501. 

  6501.       TLONO=TLONHX(I,J)+2.*DLM
    6502. 

  6502.       DLM2=TLON-TLONO
    6503. 

  6503.       DLA2=TLAT-TLATO                                               ! Q
    6504. 

  6504. !     DL2=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM2)+SIN(TLAT)*SIN(TLATO)) ! Q
    6505. 

  6505.       DL2=SQRT(DLM2*DLM2+DLA2*DLA2)                                 ! Q
    6506. 

  6506. !
    6507. 

  6507.       TLATO=TLATHX(I,J)-DPH
    6508. 

  6508.       TLONO=TLONHX(I,J)+DLM
    6509. 

  6509.       DLM3=TLON-TLONO
    6510. 

  6510.       DLA3=TLAT-TLATO                                               ! Q
    6511. 

  6511. !     DL3=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM3)+SIN(TLAT)*SIN(TLATO)) ! Q
    6512. 

  6512.       DL3=SQRT(DLM3*DLM3+DLA3*DLA3)                                 ! Q
    6513. 

  6513. !
    6514. 

  6514.       TLATO=TLATHX(I,J)+DPH
    6515. 

  6515.       TLONO=TLONHX(I,J)+DLM
    6516. 

  6516.       DLM4=TLON-TLONO
    6517. 

  6517.       DLA4=TLAT-TLATO                                               ! Q
    6518. 

  6518. !     DL4=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM4)+SIN(TLAT)*SIN(TLATO)) ! Q
    6519. 

  6519.       DL4=SQRT(DLM4*DLM4+DLA4*DLA4)                                 ! Q
    6520. 

  6520. 

  6521. !     THE BILINEAR WEIGHTS
    6522. 

  6522. !***
    6523. 

  6523.       AN3=ATAN2(DLA1,DLM1)                                          ! Q
    6524. 

  6524.       R1=DL1*SIN(AN2-AN3)/SIN(2.*AN1)
    6525. 

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

  6526.       R1=R1/DS1
    6527. 

  6527.       S1=S1/DS1
    6528. 

  6528.       DL1I=(1.-R1)*(1.-S1)
    6529. 

  6529.       DL2I=R1*S1
    6530. 

  6530.       DL3I=R1*(1.-S1)
    6531. 

  6531.       DL4I=(1.-R1)*S1
    6532. 

  6532. !
    6533. 

  6533.       HBWGT1(I,J)=DL1I
    6534. 

  6534.       HBWGT2(I,J)=DL2I
    6535. 

  6535.       HBWGT3(I,J)=DL3I
    6536. 

  6536.       HBWGT4(I,J)=DL4I
    6537. 

  6537. !
    6538. 

  6538.     ENDIF
    6539. 

  6539. !
    6540. 

  6540. !***  FINALLY STORE IIH IN TERMS OF E-GRID INDEX
    6541. 

  6541. !
    6542. 

  6542.       IIH(I,J)=NINT(0.5*IIH(I,J))
    6543. 

  6543. 

  6544.    ENDDO
    6545. 

  6545.   ENDDO
    6546. 

  6546. 

  6547. !
    6548. 

  6548. !*** EXTENSION TO NEAREST NEIGHBOR
    6549. 

  6549. !
    6550. 

  6550.      DO J =  JTS,MIN(JTE,JDE) !-1)
    6551. 

  6551.       DO I = ITS,MIN(ITE,IDE) !-1)
    6552. 

  6552.          NBWGT(1,I,J)=HBWGT1(I,J)
    6553. 

  6553.          NBWGT(2,I,J)=HBWGT2(I,J)
    6554. 

  6554.          NBWGT(3,I,J)=HBWGT3(I,J)
    6555. 

  6555.          NBWGT(4,I,J)=HBWGT4(I,J)
    6556. 

  6556.       ENDDO
    6557. 

  6557.      ENDDO
    6558. 

  6558. 

  6559.      DO J =  JTS,MIN(JTE,JDE) !-1)
    6560. 

  6560.       DO I = ITS,MIN(ITE,IDE) !-1)
    6561. 

  6561.        AMAXVAL=0.
    6562. 

  6562.           DO N=1,4
    6563. 

  6563.             AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL)
    6564. 

  6564.           ENDDO
    6565. 

  6565. !
    6566. 

  6566.           FLIP=.TRUE.
    6567. 

  6567.           SUM=0.0
    6568. 

  6568.           DO N=1,4
    6569. 

  6569.              IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN
    6570. 

  6570.                NBWGT(N,I,J)=1.0
    6571. 

  6571.                FLIP=.FALSE.
    6572. 

  6572.              ELSE
    6573. 

  6573.                NBWGT(N,I,J)=0.0
    6574. 

  6574.              ENDIF
    6575. 

  6575.              SUM=SUM+NBWGT(N,I,J)
    6576. 

  6576.              IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" )
    6577. 

  6577.           ENDDO
    6578. 

  6578. 

  6579. 

  6580.           IF((NBWGT(1,I,J)+NBWGT(2,I,J)+NBWGT(3,I,J)+NBWGT(4,I,J)) .NE. 1)THEN
    6581. 

  6581.             WRITE(0,*)'------------------------------------------------------------------------'
    6582. 

  6582.             WRITE(0,*)'FATAL: SOMETHING IS WRONG WITH THE WEIGHTS IN module_initialize_real.F'
    6583. 

  6583.             WRITE(0,*)'------------------------------------------------------------------------'
    6584. 

  6584.             STOP
    6585. 

  6585.           ENDIF
    6586. 

  6586. 

  6587. !       WRITE(66,*)I,J,NBWGT(1,I,J),NBWGT(2,I,J),NBWGT(3,I,J),NBWGT(4,I,J)
    6588. 

  6588. 

  6589.       ENDDO
    6590. 

  6590.      ENDDO
    6591. 

  6591. 

  6592. 

  6593.      DO J=MAX(3,JTS),MIN(JTE,JDE)  !-1)
    6594. 

  6594.       DO I=MAX(3,ITS),MIN(ITE,IDE) !-1)
    6595. 

  6595.             IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7
    6596. 

  6596.                 HRES_SM(I,J) = NBWGT(1,I,J)*SM(IIH(I,J),JJH(I,J)  )    &
    6597. 

  6597.                              + NBWGT(2,I,J)*SM(IIH(I,J)+1, JJH(I,J)  )    &
    6598. 

  6598.                              + NBWGT(3,I,J)*SM(IIH(I,J),   JJH(I,J)-1)    &
    6599. 

  6599.                              + NBWGT(4,I,J)*SM(IIH(I,J),   JJH(I,J)+1)
    6600. 

  6600. !                WRITE(68,*)I,J,SM(IIH(I,J),JJH(I,J)),SM(IIH(I,J)+1, JJH(I,J)), &
    6601. 

  6601. !                               SM(IIH(I,J),   JJH(I,J)-1),SM(IIH(I,J), JJH(I,J)+1),HRES_SM(I,J)
    6602. 

  6602.             ELSE
    6603. 

  6603.                 HRES_SM(I,J) = NBWGT(1,I,J)*SM(IIH(I,J),   JJH(I,J)  )  &
    6604. 

  6604.                              + NBWGT(2,I,J)*SM(IIH(I,J)+1, JJH(I,J)  )  &
    6605. 

  6605.                              + NBWGT(3,I,J)*SM(IIH(I,J)+1, JJH(I,J)-1)  &
    6606. 

  6606.                              + NBWGT(4,I,J)*SM(IIH(I,J)+1, JJH(I,J)+1)
    6607. 

  6607. 

  6608. !                WRITE(68,*)I,J,SM(IIH(I,J),JJH(I,J)),SM(IIH(I,J)+1, JJH(I,J)), &
    6609. 

  6609. !                               SM(IIH(I,J)+1, JJH(I,J)-1),SM(IIH(I,J)+1, JJH(I,J)+1),HRES_SM(I,J)
    6610. 

  6610. 

  6611.             ENDIF
    6612. 

  6612. 

  6613.       ENDDO
    6614. 

  6614.      ENDDO
    6615. 

  6615. !    Boundary treatment in J direction
    6616. 

  6616.      DO J=MAX(3,JTS),MIN(JTE,JDE)
    6617. 

  6617.        HRES_SM(2,J)=HRES_SM(3,J)
    6618. 

  6618.        HRES_SM(1,J)=HRES_SM(2,J)
    6619. 

  6619.      END DO
    6620. 

  6620. !    Boundary treatment in J direction and 4 corners
    6621. 

  6621.      DO I=ITS,MIN(ITE,IDE) 
    6622. 

  6622.        HRES_SM(I,2)=HRES_SM(I,3)
    6623. 

  6623.        HRES_SM(I,1)=HRES_SM(I,2)
    6624. 

  6624.      END DO
    6625. 

  6625. 

  6626. 

  6627.   RETURN
    6628. 

  6628.   END SUBROUTINE G2T2H_hwrf
    6629. 

  6629. !========================================================================================
    6630. 

  6630. ! end gopal's doing for ocean coupling
    6631. 

  6631. !============================================================================================
    6632. 

  6632. #endif
    6633. 

  6633. END MODULE module_initialize_ideal
    6634. 

  6634.