source: lmdz_wrf/WRFV3/frame/module_tiles.F @ 1

Last change on this file since 1 was 1, checked in by lfita, 10 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 17.9 KB
Line 
1!WRF:DRIVER_LAYER:TILING
2!
3
4MODULE module_tiles
5
6  USE module_configure
7
8  INTERFACE set_tiles
9    MODULE PROCEDURE set_tiles1 , set_tiles2, set_tiles3
10  END INTERFACE
11
12CONTAINS
13
14! CPP macro for error checking
15#define ERROR_TEST(A,O,B) IF( A O B )THEN;WRITE(mess,'(3A4)')'A','O','B';CALL WRF_ERROR_FATAL(mess);ENDIF
16
17! this version is used to compute only on a boundary of some width
18! The ids, ide, jds, and jde arguments specify the edge of the boundary (a way of
19! accounting for staggering, and the bdyw gives the number of cells
20! (idea: if bdyw is negative, have it do the reverse and specify the
21! interior, less the boundary.
22
23  SUBROUTINE set_tiles1 ( grid , ids , ide , jds , jde , bdyw )
24
25     USE module_domain, ONLY : domain
26     USE module_driver_constants
27     USE module_machine
28     USE module_wrf_error
29
30     IMPLICIT NONE
31 
32     !  Input data.
33 
34     TYPE(domain)                   , INTENT(INOUT)  :: grid
35     INTEGER                        , INTENT(IN)     :: ids , ide , jds , jde , bdyw
36
37     !  Local data
38
39     INTEGER                                :: spx, epx, spy, epy, t, tt, ts, te
40     INTEGER                                :: smx, emx, smy, emy
41     INTEGER                                :: ntiles , num_tiles
42
43     CHARACTER*80              :: mess
44
45     data_ordering : SELECT CASE ( model_data_order )
46       CASE  ( DATA_ORDER_XYZ )
47         spx = grid%sp31 ; epx = grid%ep31 ; spy = grid%sp32 ; epy = grid%ep32
48       CASE  ( DATA_ORDER_YXZ )
49         spx = grid%sp32 ; epx = grid%ep32 ; spy = grid%sp31 ; epy = grid%ep31
50       CASE  ( DATA_ORDER_ZXY )
51         spx = grid%sp32 ; epx = grid%ep32 ; spy = grid%sp33 ; epy = grid%ep33
52       CASE  ( DATA_ORDER_ZYX )
53         spx = grid%sp33 ; epx = grid%ep33 ; spy = grid%sp32 ; epy = grid%ep32
54       CASE  ( DATA_ORDER_XZY )
55         spx = grid%sp31 ; epx = grid%ep31 ; spy = grid%sp33 ; epy = grid%ep33
56       CASE  ( DATA_ORDER_YZX )
57         spx = grid%sp33 ; epx = grid%ep33 ; spy = grid%sp31 ; epy = grid%ep31
58     END SELECT data_ordering
59
60     num_tiles = 4
61
62     IF ( num_tiles > grid%max_tiles ) THEN
63       IF ( ASSOCIATED(grid%i_start) ) THEN ; DEALLOCATE( grid%i_start ) ; NULLIFY( grid%i_start ) ; ENDIF
64       IF ( ASSOCIATED(grid%i_end) )   THEN ; DEALLOCATE( grid%i_end   ) ; NULLIFY( grid%i_end   ) ; ENDIF
65       IF ( ASSOCIATED(grid%j_start) ) THEN ; DEALLOCATE( grid%j_start ) ; NULLIFY( grid%j_start ) ; ENDIF
66       IF ( ASSOCIATED(grid%j_end) )   THEN ; DEALLOCATE( grid%j_end   ) ; NULLIFY( grid%j_end   ) ; ENDIF
67       ALLOCATE(grid%i_start(num_tiles))
68       ALLOCATE(grid%i_end(num_tiles))
69       ALLOCATE(grid%j_start(num_tiles))
70       ALLOCATE(grid%j_end(num_tiles))
71       grid%max_tiles = num_tiles
72     ENDIF
73
74! XS boundary
75     IF      ( ids .ge. spx .and. ids .le. epx ) THEN
76        grid%i_start(1) = ids
77        grid%i_end(1)   = min( ids+bdyw-1 , epx )
78        grid%j_start(1) = max( spy , jds )
79        grid%j_end(1)   = min( epy , jde )
80     ELSEIF  ( (ids+bdyw-1) .ge. spx .and. (ids+bdyw-1) .le. epx ) THEN
81        grid%i_start(1) = max( ids , spx )
82        grid%i_end(1)   = ids+bdyw-1
83        grid%j_start(1) = max( spy , jds )
84        grid%j_end(1)   = min( epy , jde )
85     ELSE
86        grid%i_start(1) = 1
87        grid%i_end(1)   = -1
88        grid%j_start(1) = 1
89        grid%j_end(1)   = -1
90     ENDIF
91
92! XE boundary
93     IF      ( ide .ge. spx .and. ide .le. epx ) THEN
94        grid%i_start(2) = max( ide-bdyw+1 , spx )
95        grid%i_end(2)   = ide
96        grid%j_start(2) = max( spy , jds )
97        grid%j_end(2)   = min( epy , jde )
98     ELSEIF  ( (ide-bdyw+1) .ge. spx .and. (ide-bdyw+1) .le. epx ) THEN
99        grid%i_start(2) = ide-bdyw+1
100        grid%i_end(2)   = min( ide , epx )
101        grid%j_start(2) = max( spy , jds )
102        grid%j_end(2)   = min( epy , jde )
103     ELSE
104        grid%i_start(2) = 1
105        grid%i_end(2)   = -1
106        grid%j_start(2) = 1
107        grid%j_end(2)   = -1
108     ENDIF
109
110! YS boundary (note that the corners may already be done by XS and XE)
111     IF      ( jds .ge. spy .and. jds .le. epy ) THEN
112        grid%j_start(3) = jds
113        grid%j_end(3)   = min( jds+bdyw-1 , epy )
114        grid%i_start(3) = max( spx , ids+bdyw )
115        grid%i_end(3)   = min( epx , ide-bdyw )
116     ELSEIF  ( (jds+bdyw-1) .ge. spy .and. (jds+bdyw-1) .le. epy ) THEN
117        grid%j_start(3) = max( jds , spy )
118        grid%j_end(3)   = jds+bdyw-1
119        grid%i_start(3) = max( spx , ids+bdyw )
120        grid%i_end(3)   = min( epx , ide-bdyw )
121     ELSE
122        grid%j_start(3) = 1
123        grid%j_end(3)   = -1
124        grid%i_start(3) = 1
125        grid%i_end(3)   = -1
126     ENDIF
127
128! YE boundary (note that the corners may already be done by XS and XE)
129     IF      ( jde .ge. spy .and. jde .le. epy ) THEN
130        grid%j_start(4) = max( jde-bdyw+1 , spy )
131        grid%j_end(4)   = jde
132        grid%i_start(4) = max( spx , ids+bdyw )
133        grid%i_end(4)   = min( epx , ide-bdyw )
134     ELSEIF  ( (jde-bdyw+1) .ge. spy .and. (jde-bdyw+1) .le. epy ) THEN
135        grid%j_start(4) = jde-bdyw+1
136        grid%j_end(4)   = min( jde , epy )
137        grid%i_start(4) = max( spx , ids+bdyw )
138        grid%i_end(4)   = min( epx , ide-bdyw )
139     ELSE
140        grid%j_start(4) = 1
141        grid%j_end(4)   = -1
142        grid%i_start(4) = 1
143        grid%i_end(4)   = -1
144     ENDIF
145
146     grid%num_tiles = num_tiles
147
148     RETURN
149  END SUBROUTINE set_tiles1
150
151!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
152! this version is used to limit the domain or compute onto halos
153  SUBROUTINE set_tiles2 ( grid , ids , ide , jds , jde , ips , ipe , jps , jpe )
154     USE module_domain, ONLY : domain
155     USE module_driver_constants
156     USE module_machine
157     USE module_wrf_error
158
159     IMPLICIT NONE
160 
161     !  Input data.
162 
163     TYPE(domain)                   , INTENT(INOUT)  :: grid
164     INTEGER                        , INTENT(IN)     :: ids , ide , jds , jde
165     INTEGER                        , INTENT(IN)     :: ips , ipe , jps , jpe
166
167     !  Output data.
168
169     !  Local data.
170 
171     INTEGER                                :: num_tiles_x, num_tiles_y, num_tiles
172     INTEGER                                :: tile_sz_x, tile_sz_y
173     INTEGER                                :: spx, epx, spy, epy, t, tt, ts, te
174     INTEGER                                :: smx, emx, smy, emy
175     INTEGER                                :: ntiles
176     INTEGER                                :: one
177     INTEGER                                :: nt
178#ifdef _OPENMP
179     INTEGER , EXTERNAL        :: omp_get_max_threads
180#endif
181     CHARACTER*80              :: mess
182     LOGICAL                   :: verbose ! whether to output tile info messages
183
184     data_ordering : SELECT CASE ( model_data_order )
185       CASE  ( DATA_ORDER_XYZ )
186         spx = grid%sp31 ; epx = grid%ep31 ; spy = grid%sp32 ; epy = grid%ep32
187         smx = grid%sm31 ; emx = grid%em31 ; smy = grid%sm32 ; emy = grid%em32
188       CASE  ( DATA_ORDER_YXZ )
189         spx = grid%sp32 ; epx = grid%ep32 ; spy = grid%sp31 ; epy = grid%ep31
190         smx = grid%sm32 ; emx = grid%em32 ; smy = grid%sm31 ; emy = grid%em31
191       CASE  ( DATA_ORDER_ZXY )
192         spx = grid%sp32 ; epx = grid%ep32 ; spy = grid%sp33 ; epy = grid%ep33
193         smx = grid%sm32 ; emx = grid%em32 ; smy = grid%sm33 ; emy = grid%em33
194       CASE  ( DATA_ORDER_ZYX )
195         spx = grid%sp33 ; epx = grid%ep33 ; spy = grid%sp32 ; epy = grid%ep32
196         smx = grid%sm33 ; emx = grid%em33 ; smy = grid%sm32 ; emy = grid%em32
197       CASE  ( DATA_ORDER_XZY )
198         spx = grid%sp31 ; epx = grid%ep31 ; spy = grid%sp33 ; epy = grid%ep33
199         smx = grid%sm31 ; emx = grid%em31 ; smy = grid%sm33 ; emy = grid%em33
200       CASE  ( DATA_ORDER_YZX )
201         spx = grid%sp33 ; epx = grid%ep33 ; spy = grid%sp31 ; epy = grid%ep31
202         smx = grid%sm33 ; emx = grid%em33 ; smy = grid%sm31 ; emy = grid%em31
203     END SELECT data_ordering
204
205     ERROR_TEST(ips,<,smx)
206     ERROR_TEST(ipe,>,emx)
207     ERROR_TEST(jps,<,smy)
208     ERROR_TEST(jpe,>,emy)
209
210     ! Here's how the number of tiles is arrived at:
211     !
212     !          if tile sizes are specified use those otherwise
213     !          if num_tiles is specified use that otherwise
214     !          if omp provides a value use that otherwise
215     !          use 1.
216     !
217
218     verbose = .false.
219     IF ( grid%num_tiles_spec .EQ. 0 ) THEN
220       verbose = .true.
221       CALL nl_get_numtiles( 1, num_tiles )
222       IF ( num_tiles .EQ. 1 ) THEN
223#ifdef _OPENMP
224         num_tiles = omp_get_max_threads()
225         WRITE(mess,'("WRF NUMBER OF TILES FROM OMP_GET_MAX_THREADS = ",I3)')num_tiles
226         CALL WRF_MESSAGE ( mess )
227#else
228         num_tiles = 1
229#endif
230       ENDIF
231! override num_tiles setting (however gotten) if tile sizes are specified
232       CALL nl_get_tile_sz_x( 1, tile_sz_x )
233       CALL nl_get_tile_sz_y( 1, tile_sz_y )
234       IF ( tile_sz_x >= 1 .and. tile_sz_y >= 1 ) THEN
235        ! figure number of whole tiles and add 1 for any partials in each dim
236          num_tiles_x = (epx-spx+1) / tile_sz_x
237          if ( tile_sz_x*num_tiles_x < epx-spx+1 ) num_tiles_x = num_tiles_x + 1
238          num_tiles_y = (epy-spy+1) / tile_sz_y
239          if ( tile_sz_y*num_tiles_y < epy-spy+1 ) num_tiles_y = num_tiles_y + 1
240          num_tiles = num_tiles_x * num_tiles_y
241       ELSE
242         IF      ( machine_info%tile_strategy == TILE_X ) THEN
243           num_tiles_x = num_tiles
244           num_tiles_y = 1
245         ELSE IF ( machine_info%tile_strategy == TILE_Y ) THEN
246           num_tiles_x = 1
247           num_tiles_y = num_tiles
248         ELSE ! Default ( machine_info%tile_strategy == TILE_XY ) THEN
249           one = 1
250           call least_aspect( num_tiles, one, one, num_tiles_y, num_tiles_x )
251         ENDIF
252       ENDIF
253       grid%num_tiles_spec = num_tiles
254       grid%num_tiles_x = num_tiles_x
255       grid%num_tiles_y = num_tiles_y
256     ELSE
257       num_tiles = grid%num_tiles_spec
258       IF      ( machine_info%tile_strategy == TILE_X ) THEN
259         num_tiles_x = num_tiles
260         num_tiles_y = 1
261       ELSE IF ( machine_info%tile_strategy == TILE_Y ) THEN
262         num_tiles_x = 1
263         num_tiles_y = num_tiles
264       ELSE ! Default ( machine_info%tile_strategy == TILE_XY ) THEN
265         one = 1
266         call least_aspect( num_tiles, one, one, num_tiles_y, num_tiles_x )
267       ENDIF
268       grid%num_tiles_x = num_tiles_x
269       grid%num_tiles_y = num_tiles_y
270     ENDIF
271
272     num_tiles   = grid%num_tiles_spec
273     num_tiles_x = grid%num_tiles_x
274     num_tiles_y = grid%num_tiles_y
275
276     IF ( num_tiles > grid%max_tiles ) THEN
277       IF ( ASSOCIATED(grid%i_start) ) THEN ; DEALLOCATE( grid%i_start ) ; NULLIFY( grid%i_start ) ; ENDIF
278       IF ( ASSOCIATED(grid%i_end) )   THEN ; DEALLOCATE( grid%i_end   ) ; NULLIFY( grid%i_end   ) ; ENDIF
279       IF ( ASSOCIATED(grid%j_start) ) THEN ; DEALLOCATE( grid%j_start ) ; NULLIFY( grid%j_start ) ; ENDIF
280       IF ( ASSOCIATED(grid%j_end) )   THEN ; DEALLOCATE( grid%j_end   ) ; NULLIFY( grid%j_end   ) ; ENDIF
281       ALLOCATE(grid%i_start(num_tiles))
282       ALLOCATE(grid%i_end(num_tiles))
283       ALLOCATE(grid%j_start(num_tiles))
284       ALLOCATE(grid%j_end(num_tiles))
285       grid%max_tiles = num_tiles
286     ENDIF
287
288     nt = 1
289     DO t = 0, num_tiles-1
290
291       ! do y
292        ntiles = t / num_tiles_x
293        CALL region_bounds( spy, epy,                                  &
294                            num_tiles_y, ntiles,                       &
295                            ts, te )
296        ! first y (major dimension)
297        IF ( ts .LE. te ) THEN  ! converse happens if number of tiles > number of points in dim
298!!!
299! This bit allows the user to specify execution out onto the halo region
300! in the call to set_tiles. If the low patch boundary specified by the arguments
301! is less than what the model already knows to be the patch boundary and if
302! the user hasn't erred by specifying something that would fall off memory
303! (safety tests are higher up in this routine, outside the IF) then adjust
304! the tile boundary of the low edge tiles accordingly. Likewise for high edges.
305          IF ( jps .lt. spy .and. ts .eq. spy ) ts = jps ;
306          IF ( jpe .gt. epy .and. te .eq. epy ) te = jpe ;
307!
308          grid%j_start(nt) = max ( ts , jds )
309          grid%j_end(nt)   = min ( te , jde )
310
311          ! now x
312          ntiles = mod(t,num_tiles_x)
313          CALL region_bounds( spx, epx,                                  &
314                              num_tiles_x, ntiles,                       &
315                              ts, te )
316          IF ( ts .LE. te ) THEN  ! converse happens if number of tiles > number of points in dim
317            IF ( ips .lt. spx .and. ts .eq. spx ) ts = ips ;
318            IF ( ipe .gt. epx .and. te .eq. epx ) te = ipe ;
319!!!
320            grid%i_start(nt) = max ( ts , ids )
321            grid%i_end(nt)   = min ( te , ide )
322            IF ( verbose ) THEN
323              WRITE(mess,'("WRF TILE ",I3," IS ",I6," IE ",I6," JS ",I6," JE ",I6)') &
324                        nt,grid%i_start(nt),grid%i_end(nt),grid%j_start(nt),grid%j_end(nt)
325              CALL WRF_MESSAGE ( mess )
326            ENDIF
327            nt = nt + 1
328          ENDIF
329        ENDIF
330     END DO
331     num_tiles = nt-1
332     IF ( verbose ) THEN
333       WRITE(mess,'("WRF NUMBER OF TILES = ",I3)')num_tiles
334       CALL WRF_MESSAGE ( mess )
335     ENDIF
336     grid%num_tiles = num_tiles
337
338     RETURN
339  END SUBROUTINE set_tiles2
340 
341
342!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
343! this version sets the tiles based on a passed in integer mask
344! the assumption here is that the mask is relatively straigthforward
345! and coverable with 2 or three rectangles. No weird stuff...
346
347  SUBROUTINE set_tiles3 ( grid , imask, ims, ime, jms, jme, ips, ipe, jps, jpe )
348     USE module_domain, ONLY : domain
349     USE module_driver_constants
350     USE module_machine
351     USE module_wrf_error
352
353     IMPLICIT NONE
354 
355     !  Input data.
356 
357     TYPE(domain)                   , INTENT(INOUT)  :: grid
358     INTEGER                        , INTENT(IN)     :: ims , ime , jms , jme
359     INTEGER                        , INTENT(IN)     :: ips , ipe , jps , jpe
360     INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: imask
361     INTEGER                :: num_tiles
362     INTEGER, DIMENSION(50) :: i_start, i_end, j_start, j_end
363
364     !  Output data.
365
366     !  Local data.
367     INTEGER nt
368     CHARACTER*80              :: mess
369
370     CALL set_tiles_masked ( imask, ims, ime, jms, jme, ips, ipe, jps, jpe, &
371                             num_tiles, i_start, i_end, j_start, j_end )
372
373     IF ( num_tiles > grid%max_tiles ) THEN
374       IF ( ASSOCIATED(grid%i_start) ) THEN ; DEALLOCATE( grid%i_start ) ; NULLIFY( grid%i_start ) ; ENDIF
375       IF ( ASSOCIATED(grid%i_end) )   THEN ; DEALLOCATE( grid%i_end   ) ; NULLIFY( grid%i_end   ) ; ENDIF
376       IF ( ASSOCIATED(grid%j_start) ) THEN ; DEALLOCATE( grid%j_start ) ; NULLIFY( grid%j_start ) ; ENDIF
377       IF ( ASSOCIATED(grid%j_end) )   THEN ; DEALLOCATE( grid%j_end   ) ; NULLIFY( grid%j_end   ) ; ENDIF
378       ALLOCATE(grid%i_start(num_tiles))
379       ALLOCATE(grid%i_end(num_tiles))
380       ALLOCATE(grid%j_start(num_tiles))
381       ALLOCATE(grid%j_end(num_tiles))
382       grid%max_tiles = num_tiles
383     ENDIF
384     grid%num_tiles = num_tiles
385     grid%i_start(1:num_tiles) = i_start(1:num_tiles)
386     grid%i_end(1:num_tiles)   = i_end(1:num_tiles)
387     grid%j_start(1:num_tiles) = j_start(1:num_tiles)
388     grid%j_end(1:num_tiles)   = j_end(1:num_tiles)
389     DO nt = 1, num_tiles
390        WRITE(mess,'("WRF TILE ",I3," IS ",I6," IE ",I6," JS ",I6," JE ",I6)') &
391                      nt,grid%i_start(nt),grid%i_end(nt),grid%j_start(nt),grid%j_end(nt)
392        CALL wrf_debug ( 1, mess )
393     ENDDO
394     WRITE(mess,'("set_tiles3: NUMBER OF TILES = ",I3)')num_tiles
395     CALL wrf_debug ( 1, mess )
396
397     RETURN
398  END SUBROUTINE set_tiles3
399
400  SUBROUTINE set_tiles_masked ( imask, ims, ime, jms, jme, ips, ipe, jps, jpe, &
401                                num_tiles, istarts, iends, jstarts, jends )
402
403      IMPLICIT NONE
404
405      !  Arguments
406
407      INTEGER                        , INTENT(IN)     :: ims , ime , jms , jme
408      INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: imask
409      INTEGER                        , INTENT(IN)     :: ips , ipe , jps , jpe
410      INTEGER                        , INTENT(OUT)    :: num_tiles
411      INTEGER, DIMENSION(*)          , INTENT(OUT)    :: istarts, iends
412      INTEGER, DIMENSION(*)          , INTENT(OUT)    :: jstarts, jends
413
414      !  Output data.
415
416      !  Local data.
417      CHARACTER*80              :: mess
418      INTEGER :: i, j, ir, jr
419      INTEGER :: imaskcopy(ips:ipe,jps:jpe)    ! copy of imask to write on
420
421      imaskcopy = imask(ips:ipe,jps:jpe)
422      num_tiles = 0
423      ! simple multi-pass scheme, optimize later...
424      DO WHILE (ANY(imaskcopy == 1))
425        DO j = jps,jpe
426          DO i = ips,ipe
427            ! find first "1" and build a rectangle from it
428            IF ( imaskcopy(i,j) == 1 ) THEN
429              num_tiles = num_tiles + 1
430              istarts(num_tiles) = i
431              iends(num_tiles)   = i
432              jstarts(num_tiles) = j
433              jends(num_tiles)   = j
434              ! don't check this point again
435              imaskcopy(i,j) = 0
436              ! find length of first row
437              DO ir = istarts(num_tiles)+1,ipe
438                IF ( imaskcopy(ir,j) == 1 ) THEN
439                  iends(num_tiles) = ir
440                  ! don't check this point again
441                  imaskcopy(ir,j) = 0
442                ELSE
443                  EXIT
444                ENDIF
445              ENDDO
446              ! find number of rows
447              DO jr = jstarts(num_tiles)+1,jpe
448                IF (ALL(imaskcopy(istarts(num_tiles):iends(num_tiles),jr) == 1)) THEN
449                  jends(num_tiles) = jr
450                  ! don't check these points again
451                  imaskcopy(istarts(num_tiles):iends(num_tiles),jr) = 0
452                ELSE
453                  EXIT
454                ENDIF
455              ENDDO
456            ENDIF   ! if ( imaskcopy(i,j) == 1 )
457          ENDDO
458        ENDDO
459      ENDDO
460      RETURN
461  END SUBROUTINE set_tiles_masked
462
463 
464  SUBROUTINE init_module_tiles
465  END SUBROUTINE init_module_tiles
466
467END MODULE module_tiles
468
Note: See TracBrowser for help on using the repository browser.