nest_init_utils.F
References to this file elsewhere.
1 SUBROUTINE init_domain_constants_em ( parent , nest )
2 USE module_domain
3 USE module_configure
4 IMPLICIT NONE
5 TYPE(domain) :: parent , nest
6
7 INTEGER iswater , map_proj, julyr, julday
8 REAL cen_lat, cen_lon, truelat1 , truelat2 , gmt , moad_cen_lat , stand_lon
9 CHARACTER (LEN=4) :: char_junk
10
11 ! single-value constants
12
13 nest%p_top = parent%p_top
14 nest%cfn = parent%cfn
15 nest%cfn1 = parent%cfn1
16 nest%rdx = 1./nest%dx
17 nest%rdy = 1./nest%dy
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?
22 nest%cf1 = parent%cf1
23 nest%cf2 = parent%cf2
24 nest%cf3 = parent%cf3
25 nest%gmt = parent%gmt
26 nest%julyr = parent%julyr
27 nest%julday = parent%julday
28
29 CALL nl_get_mminlu ( 1,char_junk(1:4) )
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_map_proj ( 1 , map_proj )
36 CALL nl_get_gmt ( 1 , gmt)
37 CALL nl_get_julyr ( 1 , julyr)
38 CALL nl_get_julday ( 1 , julday)
39 IF ( nest%id .NE. 1 ) THEN
40 CALL nl_set_gmt (nest%id, gmt)
41 CALL nl_set_julyr (nest%id, julyr)
42 CALL nl_set_julday (nest%id, julday)
43 CALL nl_set_iswater (nest%id, iswater )
44 CALL nl_set_truelat1 ( nest%id , truelat1 )
45 CALL nl_set_truelat2 ( nest%id , truelat2 )
46 CALL nl_set_moad_cen_lat ( nest%id , moad_cen_lat )
47 CALL nl_set_stand_lon ( nest%id , stand_lon )
48 CALL nl_set_map_proj ( nest%id , map_proj )
49 END IF
50 nest%gmt = gmt
51 nest%julday = julday
52 nest%julyr = julyr
53 nest%iswater = iswater
54 nest%cen_lat = cen_lat
55 nest%cen_lon = cen_lon
56 nest%truelat1= truelat1
57 nest%truelat2= truelat2
58 nest%moad_cen_lat= moad_cen_lat
59 nest%stand_lon= stand_lon
60 nest%map_proj= map_proj
61
62 nest%step_number = parent%step_number
63
64 ! 1D constants (Z)
65
66 nest%em_fnm = parent%em_fnm
67 nest%em_fnp = parent%em_fnp
68 nest%em_rdnw = parent%em_rdnw
69 nest%em_rdn = parent%em_rdn
70 nest%em_dnw = parent%em_dnw
71 nest%em_dn = parent%em_dn
72 nest%em_znu = parent%em_znu
73 nest%em_znw = parent%em_znw
74 nest%em_t_base = parent%em_t_base
75 nest%u_base = parent%u_base
76 nest%v_base = parent%v_base
77 nest%qv_base = parent%qv_base
78 nest%z_base = parent%z_base
79 nest%dzs = parent%dzs
80 nest%zs = parent%zs
81
82 END SUBROUTINE init_domain_constants_em
83
84 SUBROUTINE blend_terrain ( ter_interpolated , ter_input , &
85 ids , ide , jds , jde , kds , kde , &
86 ims , ime , jms , jme , kms , kme , &
87 ips , ipe , jps , jpe , kps , kpe )
88
89 USE module_configure
90 IMPLICIT NONE
91
92 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
93 ims , ime , jms , jme , kms , kme , &
94 ips , ipe , jps , jpe , kps , kpe
95 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: ter_interpolated
96 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: ter_input
97
98 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: ter_temp
99 INTEGER :: i , j , k , spec_bdy_width
100 REAL :: r_blend_zones
101 INTEGER blend_cell, blend_width
102
103 ! The fine grid elevation comes from the horizontally interpolated
104 ! parent elevation for the first spec_bdy_width row/columns, so we need
105 ! to get that value. We blend the coarse and fine in the next blend_width
106 ! rows and columns. After that, in the interior, it is 100% fine grid.
107
108 CALL nl_get_spec_bdy_width ( 1, spec_bdy_width)
109 CALL nl_get_blend_width ( 1, blend_width)
110
111 ! Initialize temp values to the nest ter elevation. This fills in the values
112 ! that will not be modified below.
113
114 DO j = jps , MIN(jpe, jde-1)
115 DO k = kps , kpe
116 DO i = ips , MIN(ipe, ide-1)
117 ter_temp(i,k,j) = ter_input(i,k,j)
118 END DO
119 END DO
120 END DO
121
122 ! To avoid some tricky indexing, we fill in the values inside out. This allows
123 ! us to overwrite incorrect assignments. There are replicated assignments, and
124 ! there is much unnecessary "IF test inside of a loop" stuff. For a large
125 ! domain, this is only a patch; for a small domain, this is not a biggy.
126
127 r_blend_zones = 1./(blend_width+1)
128 DO j = jps , MIN(jpe, jde-1)
129 DO k = kps , kpe
130 DO i = ips , MIN(ipe, ide-1)
131 DO blend_cell = blend_width,1,-1
132 IF ( ( i .EQ. spec_bdy_width + blend_cell ) .OR. ( j .EQ. spec_bdy_width + blend_cell ) .OR. &
133 ( i .EQ. ide - spec_bdy_width - blend_cell ) .OR. ( j .EQ. jde - spec_bdy_width - blend_cell ) ) THEN
134 ter_temp(i,k,j) = ( (blend_cell)*ter_input(i,k,j) + (blend_width+1-blend_cell)*ter_interpolated(i,k,j) ) &
135 * r_blend_zones
136 END IF
137 ENDDO
138 IF ( ( i .LE. spec_bdy_width ) .OR. ( j .LE. spec_bdy_width ) .OR. &
139 ( i .GE. ide - spec_bdy_width ) .OR. ( j .GE. jde - spec_bdy_width ) ) THEN
140 ter_temp(i,k,j) = ter_interpolated(i,k,j)
141 END IF
142 END DO
143 END DO
144 END DO
145
146 ! Set nest elevation with temp values. All values not overwritten in the above
147 ! loops have been previously set in the initial assignment.
148
149 DO j = jps , MIN(jpe, jde-1)
150 DO k = kps , kpe
151 DO i = ips , MIN(ipe, ide-1)
152 ter_input(i,k,j) = ter_temp(i,k,j)
153 END DO
154 END DO
155 END DO
156
157 END SUBROUTINE blend_terrain
158
159 SUBROUTINE store_terrain ( ter_interpolated , ter_input , &
160 ids , ide , jds , jde , kds , kde , &
161 ims , ime , jms , jme , kms , kme , &
162 ips , ipe , jps , jpe , kps , kpe )
163
164 IMPLICIT NONE
165
166 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
167 ims , ime , jms , jme , kms , kme , &
168 ips , ipe , jps , jpe , kps , kpe
169 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: ter_interpolated
170 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: ter_input
171
172 INTEGER :: i , j , k
173
174 DO j = jps , MIN(jpe, jde-1)
175 DO k = kps , kpe
176 DO i = ips , MIN(ipe, ide-1)
177 ter_interpolated(i,k,j) = ter_input(i,k,j)
178 END DO
179 END DO
180 END DO
181
182 END SUBROUTINE store_terrain
183
184
185 SUBROUTINE input_terrain_rsmas ( grid , &
186 ids , ide , jds , jde , kds , kde , &
187 ims , ime , jms , jme , kms , kme , &
188 ips , ipe , jps , jpe , kps , kpe )
189
190 USE module_domain
191 IMPLICIT NONE
192 TYPE ( domain ) :: grid
193
194 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
195 ims , ime , jms , jme , kms , kme , &
196 ips , ipe , jps , jpe , kps , kpe
197
198 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
199
200 INTEGER :: i , j , k , myproc
201 INTEGER, DIMENSION(256) :: ipath ! array for integer coded ascii for passing path down to get_terrain
202 CHARACTER*256 :: message, message2
203 CHARACTER*256 :: rsmas_data_path
204
205 #if DM_PARALLEL
206 ! Local globally sized arrays
207 REAL , DIMENSION(ids:ide,jds:jde) :: ht_g, xlat_g, xlon_g
208 #endif
209
210 CALL wrf_get_myproc ( myproc )
211
212 #if 0
213 CALL domain_clock_get ( grid, current_timestr=message2 )
214 WRITE ( message , FMT = '(A," HT before ",I3)' ) TRIM(message2), grid%id
215 write(30+myproc,*)ipe-ips+1,jpe-jps+1,trim(message)
216 do j = jps,jpe
217 do i = ips,ipe
218 write(30+myproc,*)grid%ht(i,j)
219 enddo
220 enddo
221 #endif
222
223 CALL nl_get_rsmas_data_path(1,rsmas_data_path)
224 do i = 1, LEN(TRIM(rsmas_data_path))
225 ipath(i) = ICHAR(rsmas_data_path(i:i))
226 enddo
227
228 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
229
230 CALL wrf_patch_to_global_real ( grid%xlat , xlat_g , grid%domdesc, ' ' , 'xy' , &
231 ids, ide-1 , jds , jde-1 , 1 , 1 , &
232 ims, ime , jms , jme , 1 , 1 , &
233 ips, ipe , jps , jpe , 1 , 1 )
234 CALL wrf_patch_to_global_real ( grid%xlong , xlon_g , grid%domdesc, ' ' , 'xy' , &
235 ids, ide-1 , jds , jde-1 , 1 , 1 , &
236 ims, ime , jms , jme , 1 , 1 , &
237 ips, ipe , jps , jpe , 1 , 1 )
238
239 IF ( wrf_dm_on_monitor() ) THEN
240 CALL get_terrain ( grid%dx/1000., xlat_g(ids:ide,jds:jde), xlon_g(ids:ide,jds:jde), ht_g(ids:ide,jds:jde), &
241 ide-ids+1,jde-jds+1,ide-ids+1,jde-jds+1, ipath, LEN(TRIM(rsmas_data_path)) )
242 WHERE ( ht_g(ids:ide,jds:jde) < -1000. ) ht_g(ids:ide,jds:jde) = 0.
243 ENDIF
244
245 CALL wrf_global_to_patch_real ( ht_g , grid%ht , grid%domdesc, ' ' , 'xy' , &
246 ids, ide-1 , jds , jde-1 , 1 , 1 , &
247 ims, ime , jms , jme , 1 , 1 , &
248 ips, ipe , jps , jpe , 1 , 1 )
249 #else
250
251 CALL get_terrain ( grid%dx/1000., grid%xlat(ids:ide,jds:jde), grid%xlong(ids:ide,jds:jde), grid%ht(ids:ide,jds:jde), &
252 ide-ids+1,jde-jds+1,ide-ids+1,jde-jds+1, ipath, LEN(TRIM(rsmas_data_path)) )
253 WHERE ( grid%ht(ids:ide,jds:jde) < -1000. ) grid%ht(ids:ide,jds:jde) = 0.
254
255 #endif
256
257 #if 0
258 CALL domain_clock_get ( grid, current_timestr=message2 )
259 WRITE ( message , FMT = '(A," HT after ",I3)' ) TRIM(message2), grid%id
260 write(30+myproc,*)ipe-ips+1,jpe-jps+1,trim(message)
261 do j = jps,jpe
262 do i = ips,ipe
263 write(30+myproc,*)grid%ht(i,j)
264 enddo
265 enddo
266 #endif
267
268 END SUBROUTINE input_terrain_rsmas
269
270 SUBROUTINE update_after_feedback_em ( grid &
271 !
272 #include "em_dummy_new_args.inc"
273 !
274 )
275 !
276 ! perform core specific updates, exchanges after
277 ! model feedback (called from med_feedback_domain) -John
278 !
279
280 ! Driver layer modules
281 USE module_domain
282 USE module_configure
283 USE module_driver_constants
284 USE module_machine
285 USE module_tiles
286 USE module_dm
287 USE module_bc
288 ! Mediation layer modules
289 ! Registry generated module
290 USE module_state_description
291
292 IMPLICIT NONE
293
294 ! Subroutine interface block.
295
296 TYPE(domain) , TARGET :: grid
297
298 ! Definitions of dummy arguments
299 #include <em_dummy_new_decl.inc>
300
301 INTEGER :: ids , ide , jds , jde , kds , kde , &
302 ims , ime , jms , jme , kms , kme , &
303 ips , ipe , jps , jpe , kps , kpe
304
305 CALL wrf_debug( 500, "entering update_after_feedback_em" )
306
307 #ifdef DM_PARALLEL
308 # define REGISTER_I1
309 # include <em_data_calls.inc>
310 #endif
311
312 ! Obtain dimension information stored in the grid data structure.
313 CALL get_ijk_from_grid ( grid , &
314 ids, ide, jds, jde, kds, kde, &
315 ims, ime, jms, jme, kms, kme, &
316 ips, ipe, jps, jpe, kps, kpe )
317
318 CALL wrf_debug( 500, "before HALO_EM_FEEDBACK.inc in update_after_feedback_em" )
319 #ifdef DM_PARALLEL
320 #include "HALO_EM_FEEDBACK.inc"
321 #endif
322 CALL wrf_debug( 500, "leaving update_after_feedback_em" )
323
324 END SUBROUTINE update_after_feedback_em
325