1 SUBROUTINE init_domain_constants_em ( parent , nest )
2 USE module_domain, ONLY : domain
4 TYPE(domain) :: parent , nest
6 INTEGER iswater , map_proj, julyr, julday
7 REAL truelat1 , truelat2 , gmt , moad_cen_lat , stand_lon, pole_lat, pole_lon
8 CHARACTER (LEN=256) :: char_junk
10 ! single-value constants
12 nest%p_top = parent%p_top
13 nest%save_topo_from_real = parent%save_topo_from_real
15 nest%cfn1 = parent%cfn1
18 ! nest%dts = nest%dt/float(nest%time_step_sound)
19 nest%dtseps = parent%dtseps ! used in height model only?
20 nest%resm = parent%resm ! used in height model only?
21 nest%zetatop = parent%zetatop ! used in height model only?
26 nest%julyr = parent%julyr
27 nest%julday = parent%julday
29 CALL nl_get_mminlu ( 1,char_junk(1:256) )
30 CALL nl_get_iswater (1, iswater )
31 CALL nl_get_truelat1 ( 1 , truelat1 )
32 CALL nl_get_truelat2 ( 1 , truelat2 )
33 CALL nl_get_moad_cen_lat ( 1 , moad_cen_lat )
34 CALL nl_get_stand_lon ( 1 , stand_lon )
35 CALL nl_get_pole_lat ( 1 , pole_lat )
36 CALL nl_get_pole_lon ( 1 , pole_lon )
37 CALL nl_get_map_proj ( 1 , map_proj )
38 CALL nl_get_gmt ( 1 , gmt)
39 CALL nl_get_julyr ( 1 , julyr)
40 CALL nl_get_julday ( 1 , julday)
41 IF ( nest%id .NE. 1 ) THEN
42 CALL nl_set_gmt (nest%id, gmt)
43 CALL nl_set_julyr (nest%id, julyr)
44 CALL nl_set_julday (nest%id, julday)
45 CALL nl_set_iswater (nest%id, iswater )
46 CALL nl_set_truelat1 ( nest%id , truelat1 )
47 CALL nl_set_truelat2 ( nest%id , truelat2 )
48 CALL nl_set_moad_cen_lat ( nest%id , moad_cen_lat )
49 CALL nl_set_stand_lon ( nest%id , stand_lon )
50 CALL nl_set_pole_lat ( nest%id , pole_lat )
51 CALL nl_set_pole_lon ( nest%id , pole_lon )
52 CALL nl_set_map_proj ( nest%id , map_proj )
57 nest%iswater = iswater
58 nest%truelat1= truelat1
59 nest%truelat2= truelat2
60 nest%moad_cen_lat= moad_cen_lat
61 nest%stand_lon= stand_lon
62 nest%pole_lat= pole_lat
63 nest%pole_lon= pole_lon
64 nest%map_proj= map_proj
66 nest%step_number = parent%step_number
72 nest%rdnw = parent%rdnw
78 nest%t_base = parent%t_base
79 nest%u_base = parent%u_base
80 nest%v_base = parent%v_base
81 nest%qv_base = parent%qv_base
82 nest%z_base = parent%z_base
86 END SUBROUTINE init_domain_constants_em
88 SUBROUTINE blend_terrain ( ter_interpolated , ter_input , &
89 ids , ide , jds , jde , kds , kde , &
90 ims , ime , jms , jme , kms , kme , &
91 ips , ipe , jps , jpe , kps , kpe )
96 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
97 ims , ime , jms , jme , kms , kme , &
98 ips , ipe , jps , jpe , kps , kpe
99 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: ter_interpolated
100 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: ter_input
102 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: ter_temp
103 INTEGER :: i , j , k , spec_bdy_width
104 REAL :: r_blend_zones
105 INTEGER blend_cell, blend_width
107 ! The fine grid elevation comes from the horizontally interpolated
108 ! parent elevation for the first spec_bdy_width row/columns, so we need
109 ! to get that value. We blend the coarse and fine in the next blend_width
110 ! rows and columns. After that, in the interior, it is 100% fine grid.
112 CALL nl_get_spec_bdy_width ( 1, spec_bdy_width)
113 CALL nl_get_blend_width ( 1, blend_width)
115 ! Initialize temp values to the nest ter elevation. This fills in the values
116 ! that will not be modified below.
118 DO j = jps , MIN(jpe, jde-1)
120 DO i = ips , MIN(ipe, ide-1)
121 ter_temp(i,k,j) = ter_input(i,k,j)
126 ! To avoid some tricky indexing, we fill in the values inside out. This allows
127 ! us to overwrite incorrect assignments. There are replicated assignments, and
128 ! there is much unnecessary "IF test inside of a loop" stuff. For a large
129 ! domain, this is only a patch; for a small domain, this is not a biggy.
131 r_blend_zones = 1./(blend_width+1)
132 DO j = jps , MIN(jpe, jde-1)
134 DO i = ips , MIN(ipe, ide-1)
135 DO blend_cell = blend_width,1,-1
136 IF ( ( i .EQ. spec_bdy_width + blend_cell ) .OR. ( j .EQ. spec_bdy_width + blend_cell ) .OR. &
137 ( i .EQ. ide - spec_bdy_width - blend_cell ) .OR. ( j .EQ. jde - spec_bdy_width - blend_cell ) ) THEN
138 ter_temp(i,k,j) = ( (blend_cell)*ter_input(i,k,j) + (blend_width+1-blend_cell)*ter_interpolated(i,k,j) ) &
142 IF ( ( i .LE. spec_bdy_width ) .OR. ( j .LE. spec_bdy_width ) .OR. &
143 ( i .GE. ide - spec_bdy_width ) .OR. ( j .GE. jde - spec_bdy_width ) ) THEN
144 ter_temp(i,k,j) = ter_interpolated(i,k,j)
150 ! Set nest elevation with temp values. All values not overwritten in the above
151 ! loops have been previously set in the initial assignment.
153 DO j = jps , MIN(jpe, jde-1)
155 DO i = ips , MIN(ipe, ide-1)
156 ter_input(i,k,j) = ter_temp(i,k,j)
161 END SUBROUTINE blend_terrain
163 SUBROUTINE copy_3d_field ( ter_interpolated , ter_input , &
164 ids , ide , jds , jde , kds , kde , &
165 ims , ime , jms , jme , kms , kme , &
166 ips , ipe , jps , jpe , kps , kpe )
170 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
171 ims , ime , jms , jme , kms , kme , &
172 ips , ipe , jps , jpe , kps , kpe
173 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: ter_interpolated
174 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: ter_input
178 DO j = jps , MIN(jpe, jde-1)
180 DO i = ips , MIN(ipe, ide-1)
181 ter_interpolated(i,k,j) = ter_input(i,k,j)
186 END SUBROUTINE copy_3d_field
188 SUBROUTINE adjust_tempqv ( mub, save_mub, znw, p_top, &
190 ids , ide , jds , jde , kds , kde , &
191 ims , ime , jms , jme , kms , kme , &
192 ips , ipe , jps , jpe , kps , kpe )
194 !USE module_configure
196 USE module_model_constants
199 !USE module_io_domain
200 !USE module_state_description
205 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
206 ims , ime , jms , jme , kms , kme , &
207 ips , ipe , jps , jpe , kps , kpe
208 REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: mub, save_mub
209 REAL , DIMENSION(kms:kme) , INTENT(IN) :: znw
210 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: th, pp, qv
212 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: p_old, p_new, rh
213 REAL :: es,dth,tc,e,dth1
219 ! p_old = full pressure before terrain blending; also compute initial RH
220 ! which is going to be conserved during terrain blending
221 DO j = jps , MIN(jpe, jde-1)
223 DO i = ips , MIN(ipe, ide-1)
224 p_old(i,k,j) = 0.5*(znw(k+1)+znw(k))*save_mub(i,j) + p_top + pp(i,k,j)
225 tc = (th(i,k,j)+300.)*(p_old(i,k,j)/1.e5)**(2./7.) - 273.15
226 es = 610.78*exp(17.0809*tc/(234.175+tc))
227 e = qv(i,k,j)*p_old(i,k,j)/(0.622+qv(i,k,j))
233 ! p_new = full pressure after terrain blending; also compute temperature correction and convert RH back to QV
234 DO j = jps , MIN(jpe, jde-1)
236 DO i = ips , MIN(ipe, ide-1)
237 p_new(i,k,j) = 0.5*(znw(k+1)+znw(k))*mub(i,j) + p_top + pp(i,k,j)
238 ! 2*(g/cp-6.5e-3)*R_dry/g = -191.86e-3
239 dth1 = -191.86e-3*(th(i,k,j)+300.)/(p_new(i,k,j)+p_old(i,k,j))*(p_new(i,k,j)-p_old(i,k,j))
240 dth = -191.86e-3*(th(i,k,j)+0.5*dth1+300.)/(p_new(i,k,j)+p_old(i,k,j))*(p_new(i,k,j)-p_old(i,k,j))
241 th(i,k,j) = th(i,k,j)+dth
242 tc = (th(i,k,j)+300.)*(p_new(i,k,j)/1.e5)**(2./7.) - 273.15
243 es = 610.78*exp(17.0809*tc/(234.175+tc))
245 qv(i,k,j) = 0.622*e/(p_new(i,k,j)-e)
251 END SUBROUTINE adjust_tempqv
253 SUBROUTINE input_terrain_rsmas ( grid , &
254 ids , ide , jds , jde , kds , kde , &
255 ims , ime , jms , jme , kms , kme , &
256 ips , ipe , jps , jpe , kps , kpe )
258 USE module_domain, ONLY : domain
260 TYPE ( domain ) :: grid
262 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
263 ims , ime , jms , jme , kms , kme , &
264 ips , ipe , jps , jpe , kps , kpe
266 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
268 INTEGER :: i , j , k , myproc
269 INTEGER, DIMENSION(256) :: ipath ! array for integer coded ascii for passing path down to get_terrain
270 CHARACTER*256 :: message, message2
271 CHARACTER*256 :: rsmas_data_path
274 ! Local globally sized arrays
275 REAL , DIMENSION(ids:ide,jds:jde) :: ht_g, xlat_g, xlon_g
278 CALL wrf_get_myproc ( myproc )
281 CALL domain_clock_get ( grid, current_timestr=message2 )
282 WRITE ( message , FMT = '(A," HT before ",I3)' ) TRIM(message2), grid%id
283 write(30+myproc,*)ipe-ips+1,jpe-jps+1,trim(message)
286 write(30+myproc,*)grid%ht(i,j)
291 CALL nl_get_rsmas_data_path(1,rsmas_data_path)
292 do i = 1, LEN(TRIM(rsmas_data_path))
293 ipath(i) = ICHAR(rsmas_data_path(i:i))
296 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
298 CALL wrf_patch_to_global_real ( grid%xlat , xlat_g , grid%domdesc, ' ' , 'xy' , &
299 ids, ide-1 , jds , jde-1 , 1 , 1 , &
300 ims, ime , jms , jme , 1 , 1 , &
301 ips, ipe , jps , jpe , 1 , 1 )
302 CALL wrf_patch_to_global_real ( grid%xlong , xlon_g , grid%domdesc, ' ' , 'xy' , &
303 ids, ide-1 , jds , jde-1 , 1 , 1 , &
304 ims, ime , jms , jme , 1 , 1 , &
305 ips, ipe , jps , jpe , 1 , 1 )
307 IF ( wrf_dm_on_monitor() ) THEN
308 CALL get_terrain ( grid%dx/1000., xlat_g(ids:ide,jds:jde), xlon_g(ids:ide,jds:jde), ht_g(ids:ide,jds:jde), &
309 ide-ids+1,jde-jds+1,ide-ids+1,jde-jds+1, ipath, LEN(TRIM(rsmas_data_path)) )
310 WHERE ( ht_g(ids:ide,jds:jde) < -1000. ) ht_g(ids:ide,jds:jde) = 0.
313 CALL wrf_global_to_patch_real ( ht_g , grid%ht , grid%domdesc, ' ' , 'xy' , &
314 ids, ide-1 , jds , jde-1 , 1 , 1 , &
315 ims, ime , jms , jme , 1 , 1 , &
316 ips, ipe , jps , jpe , 1 , 1 )
319 CALL get_terrain ( grid%dx/1000., grid%xlat(ids:ide,jds:jde), grid%xlong(ids:ide,jds:jde), grid%ht(ids:ide,jds:jde), &
320 ide-ids+1,jde-jds+1,ide-ids+1,jde-jds+1, ipath, LEN(TRIM(rsmas_data_path)) )
321 WHERE ( grid%ht(ids:ide,jds:jde) < -1000. ) grid%ht(ids:ide,jds:jde) = 0.
326 CALL domain_clock_get ( grid, current_timestr=message2 )
327 WRITE ( message , FMT = '(A," HT after ",I3)' ) TRIM(message2), grid%id
328 write(30+myproc,*)ipe-ips+1,jpe-jps+1,trim(message)
331 write(30+myproc,*)grid%ht(i,j)
336 END SUBROUTINE input_terrain_rsmas
338 SUBROUTINE update_after_feedback_em ( grid &
340 #include "dummy_new_args.inc"
344 ! perform core specific updates, exchanges after
345 ! model feedback (called from med_feedback_domain) -John
348 ! Driver layer modules
349 USE module_domain, ONLY : domain, get_ijk_from_grid
351 USE module_driver_constants
355 USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask
356 USE module_comm_dm, ONLY : HALO_EM_FEEDBACK_sub
361 ! Mediation layer modules
362 ! Registry generated module
363 USE module_state_description
367 ! Subroutine interface block.
369 TYPE(domain) , TARGET :: grid
371 ! Definitions of dummy arguments
372 #include <dummy_new_decl.inc>
374 INTEGER :: ids , ide , jds , jde , kds , kde , &
375 ims , ime , jms , jme , kms , kme , &
376 ips , ipe , jps , jpe , kps , kpe
378 CALL wrf_debug( 500, "entering update_after_feedback_em" )
380 ! Obtain dimension information stored in the grid data structure.
381 CALL get_ijk_from_grid ( grid , &
382 ids, ide, jds, jde, kds, kde, &
383 ims, ime, jms, jme, kms, kme, &
384 ips, ipe, jps, jpe, kps, kpe )
386 CALL wrf_debug( 500, "before HALO_EM_FEEDBACK.inc in update_after_feedback_em" )
388 #include "HALO_EM_FEEDBACK.inc"
390 CALL wrf_debug( 500, "leaving update_after_feedback_em" )
392 END SUBROUTINE update_after_feedback_em