source: trunk/WRF.COMMON/WRFV2/dyn_em/nest_init_utils.F @ 3806

Last change on this file since 3806 was 1780, checked in by aslmd, 8 years ago

MESOSCALE found a WRF bug which appears only with nesting and hard debug mode. not an impact at all but stringent debug mode makes the model to stop early because diagnostic CEN_LAT is not defined well. corrected the bug
File size: 11.7 KB
Line 
1SUBROUTINE 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_cen_lat ( 1 , cen_lat )
34   CALL nl_get_cen_lon ( 1 , cen_lon )
35   CALL nl_get_moad_cen_lat ( 1 , moad_cen_lat )
36   CALL nl_get_stand_lon ( 1 , stand_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_cen_lat ( nest%id , cen_lat )
47     CALL nl_set_cen_lon ( nest%id , cen_lon )
48     CALL nl_set_truelat1 ( nest%id , truelat1 )
49     CALL nl_set_truelat2 ( nest%id , truelat2 )
50     CALL nl_set_moad_cen_lat ( nest%id , moad_cen_lat )
51     CALL nl_set_stand_lon ( nest%id , stand_lon )
52     CALL nl_set_map_proj ( nest%id , map_proj )
53   END IF
54   nest%gmt     = gmt
55   nest%julday  = julday
56   nest%julyr   = julyr
57   nest%iswater = iswater
58   nest%cen_lat = cen_lat
59   nest%cen_lon = cen_lon
60   nest%truelat1= truelat1
61   nest%truelat2= truelat2
62   nest%moad_cen_lat= moad_cen_lat
63   nest%stand_lon= stand_lon
64   nest%map_proj= map_proj
65
66   nest%step_number  = parent%step_number
67
68! 1D constants (Z)
69
70   nest%em_fnm    = parent%em_fnm
71   nest%em_fnp    = parent%em_fnp
72   nest%em_rdnw   = parent%em_rdnw
73   nest%em_rdn    = parent%em_rdn
74   nest%em_dnw    = parent%em_dnw
75   nest%em_dn     = parent%em_dn
76   nest%em_znu    = parent%em_znu
77   nest%em_znw    = parent%em_znw
78   nest%em_t_base = parent%em_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
83   nest%dzs       = parent%dzs
84   nest%zs        = parent%zs
85
86END SUBROUTINE init_domain_constants_em
87
88SUBROUTINE 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 )
92
93   USE module_configure
94   IMPLICIT NONE
95
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
101
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
106
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.
111
112   CALL nl_get_spec_bdy_width ( 1, spec_bdy_width)
113   CALL nl_get_blend_width ( 1, blend_width)
114
115   !  Initialize temp values to the nest ter elevation.  This fills in the values
116   !  that will not be modified below. 
117
118   DO j = jps , MIN(jpe, jde-1)
119      DO k = kps , kpe
120         DO i = ips , MIN(ipe, ide-1)
121            ter_temp(i,k,j) = ter_input(i,k,j)
122         END DO
123      END DO
124   END DO
125
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.
130
131   r_blend_zones = 1./(blend_width+1)
132   DO j = jps , MIN(jpe, jde-1)
133      DO k = kps , kpe
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) ) &
139                                    * r_blend_zones
140               END IF
141            ENDDO
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)
145            END IF
146         END DO
147      END DO
148   END DO
149
150   !  Set nest elevation with temp values.  All values not overwritten in the above
151   !  loops have been previously set in the initial assignment.
152
153   DO j = jps , MIN(jpe, jde-1)
154      DO k = kps , kpe
155         DO i = ips , MIN(ipe, ide-1)
156            ter_input(i,k,j) = ter_temp(i,k,j)
157         END DO
158      END DO
159   END DO
160
161END SUBROUTINE blend_terrain
162
163SUBROUTINE store_terrain ( 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 )
167
168   IMPLICIT NONE
169
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
175
176   INTEGER :: i , j , k
177
178   DO j = jps , MIN(jpe, jde-1)
179      DO k = kps , kpe
180         DO i = ips , MIN(ipe, ide-1)
181            ter_interpolated(i,k,j) = ter_input(i,k,j)
182         END DO
183      END DO
184   END DO
185
186END SUBROUTINE store_terrain
187
188
189SUBROUTINE input_terrain_rsmas ( grid ,                        &
190                           ids , ide , jds , jde , kds , kde , &
191                           ims , ime , jms , jme , kms , kme , &
192                           ips , ipe , jps , jpe , kps , kpe )
193
194   USE module_domain
195   IMPLICIT NONE
196   TYPE ( domain ) :: grid
197
198   INTEGER , INTENT(IN)                       :: ids , ide , jds , jde , kds , kde , &
199                                                 ims , ime , jms , jme , kms , kme , &
200                                                 ips , ipe , jps , jpe , kps , kpe
201
202   LOGICAL, EXTERNAL ::  wrf_dm_on_monitor
203
204   INTEGER :: i , j , k , myproc
205   INTEGER, DIMENSION(256) :: ipath  ! array for integer coded ascii for passing path down to get_terrain
206   CHARACTER*256 :: message, message2
207   CHARACTER*256 :: rsmas_data_path
208
209#if DM_PARALLEL
210! Local globally sized arrays
211   REAL , DIMENSION(ids:ide,jds:jde) :: ht_g, xlat_g, xlon_g
212#endif
213
214   CALL wrf_get_myproc ( myproc )
215
216#if 0
217CALL domain_clock_get ( grid, current_timestr=message2 )
218WRITE ( message , FMT = '(A," HT before ",I3)' ) TRIM(message2), grid%id
219write(30+myproc,*)ipe-ips+1,jpe-jps+1,trim(message)
220do j = jps,jpe
221do i = ips,ipe
222write(30+myproc,*)grid%ht(i,j)
223enddo
224enddo
225#endif
226
227   CALL nl_get_rsmas_data_path(1,rsmas_data_path)
228   do i = 1, LEN(TRIM(rsmas_data_path))
229      ipath(i) = ICHAR(rsmas_data_path(i:i))
230   enddo
231
232#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
233
234   CALL wrf_patch_to_global_real ( grid%xlat , xlat_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   CALL wrf_patch_to_global_real ( grid%xlong , xlon_g , grid%domdesc, ' ' , 'xy' ,       &
239                                   ids, ide-1 , jds , jde-1 , 1 , 1 , &
240                                   ims, ime   , jms , jme   , 1 , 1 , &
241                                   ips, ipe   , jps , jpe   , 1 , 1   )
242
243   IF ( wrf_dm_on_monitor() ) THEN
244     CALL get_terrain ( grid%dx/1000., xlat_g(ids:ide,jds:jde), xlon_g(ids:ide,jds:jde), ht_g(ids:ide,jds:jde), &
245                        ide-ids+1,jde-jds+1,ide-ids+1,jde-jds+1, ipath, LEN(TRIM(rsmas_data_path)) )
246     WHERE ( ht_g(ids:ide,jds:jde) < -1000. ) ht_g(ids:ide,jds:jde) = 0.
247   ENDIF
248
249   CALL wrf_global_to_patch_real ( ht_g , grid%ht , grid%domdesc, ' ' , 'xy' ,         &
250                                   ids, ide-1 , jds , jde-1 , 1 , 1 , &
251                                   ims, ime   , jms , jme   , 1 , 1 , &
252                                   ips, ipe   , jps , jpe   , 1 , 1   )
253#else
254
255   CALL get_terrain ( grid%dx/1000., grid%xlat(ids:ide,jds:jde), grid%xlong(ids:ide,jds:jde), grid%ht(ids:ide,jds:jde), &
256                       ide-ids+1,jde-jds+1,ide-ids+1,jde-jds+1, ipath, LEN(TRIM(rsmas_data_path)) )
257   WHERE ( grid%ht(ids:ide,jds:jde) < -1000. ) grid%ht(ids:ide,jds:jde) = 0.
258
259#endif
260
261#if 0
262CALL domain_clock_get ( grid, current_timestr=message2 )
263WRITE ( message , FMT = '(A," HT after ",I3)' ) TRIM(message2), grid%id
264write(30+myproc,*)ipe-ips+1,jpe-jps+1,trim(message)
265do j = jps,jpe
266do i = ips,ipe
267write(30+myproc,*)grid%ht(i,j)
268enddo
269enddo
270#endif
271                       
272END SUBROUTINE input_terrain_rsmas
273
274SUBROUTINE update_after_feedback_em ( grid  &
275!
276#include "em_dummy_new_args.inc"
277!
278                 )
279!
280! perform core specific updates, exchanges after
281! model feedback  (called from med_feedback_domain) -John
282!
283
284! Driver layer modules
285   USE module_domain
286   USE module_configure
287   USE module_driver_constants
288   USE module_machine
289   USE module_tiles
290   USE module_dm
291   USE module_bc
292! Mediation layer modules
293! Registry generated module
294   USE module_state_description
295
296   IMPLICIT NONE
297
298   !  Subroutine interface block.
299
300   TYPE(domain) , TARGET         :: grid
301
302   !  Definitions of dummy arguments
303#include <em_dummy_new_decl.inc>
304
305   INTEGER                         :: ids , ide , jds , jde , kds , kde , &
306                                      ims , ime , jms , jme , kms , kme , &
307                                      ips , ipe , jps , jpe , kps , kpe
308
309  CALL wrf_debug( 500, "entering update_after_feedback_em" )
310
311#ifdef DM_PARALLEL
312#    define REGISTER_I1
313#      include <em_data_calls.inc>
314#endif
315
316!  Obtain dimension information stored in the grid data structure.
317  CALL get_ijk_from_grid (  grid ,                   &
318                            ids, ide, jds, jde, kds, kde,    &
319                            ims, ime, jms, jme, kms, kme,    &
320                            ips, ipe, jps, jpe, kps, kpe    )
321
322  CALL wrf_debug( 500, "before HALO_EM_FEEDBACK.inc in update_after_feedback_em" )
323#ifdef DM_PARALLEL
324#include "HALO_EM_FEEDBACK.inc"
325#endif
326  CALL wrf_debug( 500, "leaving update_after_feedback_em" )
327
328END SUBROUTINE update_after_feedback_em
329
Note: See TracBrowser for help on using the repository browser.