source: lmdz_wrf/trunk/WRFV3/external/RSL_LITE/module_dm.F @ 1361

Last change on this file since 1361 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: 172.1 KB
Line 
1!WRF:PACKAGE:RSL
2!
3MODULE module_dm
4
5   USE module_machine
6   USE module_wrf_error
7   USE module_driver_constants
8!   USE module_comm_dm
9   IMPLICIT NONE
10
11#if ( NMM_CORE == 1 ) || defined( WRF_CHEM )
12   INTEGER, PARAMETER :: max_halo_width = 6
13#else
14   INTEGER, PARAMETER :: max_halo_width = 6 ! 5
15#endif
16
17   INTEGER :: ips_save, ipe_save, jps_save, jpe_save, itrace
18
19   INTEGER ntasks, ntasks_y, ntasks_x, mytask, mytask_x, mytask_y
20   INTEGER local_communicator, local_communicator_periodic, local_iocommunicator
21   INTEGER local_communicator_x, local_communicator_y ! subcommunicators for rows and cols of mesh
22   LOGICAL :: dm_debug_flag = .FALSE.
23
24   INTERFACE wrf_dm_maxval
25#if ( defined(PROMOTE_FLOAT) || ( RWORDSIZE == DWORDSIZE ) )
26     MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer
27#else
28     MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer, wrf_dm_maxval_doubleprecision
29#endif
30   END INTERFACE
31
32   INTERFACE wrf_dm_minval                       ! gopal's doing
33#if ( defined(PROMOTE_FLOAT) || ( RWORDSIZE == DWORDSIZE ) )
34     MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer
35#else
36     MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer, wrf_dm_minval_doubleprecision
37#endif
38   END INTERFACE
39
40CONTAINS
41
42
43   SUBROUTINE MPASPECT( P, MINM, MINN, PROCMIN_M, PROCMIN_N )
44      IMPLICIT NONE
45      INTEGER P, M, N, MINI, MINM, MINN, PROCMIN_M, PROCMIN_N
46      MINI = 2*P
47      MINM = 1
48      MINN = P
49      DO M = 1, P
50        IF ( MOD( P, M ) .EQ. 0 ) THEN
51          N = P / M
52          IF ( ABS(M-N) .LT. MINI                &
53               .AND. M .GE. PROCMIN_M            &
54               .AND. N .GE. PROCMIN_N            &
55             ) THEN
56            MINI = ABS(M-N)
57            MINM = M
58            MINN = N
59          ENDIF
60        ENDIF
61      ENDDO
62      IF ( MINM .LT. PROCMIN_M .OR. MINN .LT. PROCMIN_N ) THEN
63        WRITE( wrf_err_message , * )'MPASPECT: UNABLE TO GENERATE PROCESSOR MESH.  STOPPING.'
64        CALL wrf_message ( TRIM ( wrf_err_message ) )
65        WRITE(0,*)' PROCMIN_M ', PROCMIN_M
66        WRITE( wrf_err_message , * )' PROCMIN_M ', PROCMIN_M
67        CALL wrf_message ( TRIM ( wrf_err_message ) )
68        WRITE( wrf_err_message , * )' PROCMIN_N ', PROCMIN_N
69        CALL wrf_message ( TRIM ( wrf_err_message ) )
70        WRITE( wrf_err_message , * )' P         ', P
71        CALL wrf_message ( TRIM ( wrf_err_message ) )
72        WRITE( wrf_err_message , * )' MINM      ', MINM
73        CALL wrf_message ( TRIM ( wrf_err_message ) )
74        WRITE( wrf_err_message , * )' MINN      ', MINN
75        CALL wrf_message ( TRIM ( wrf_err_message ) )
76        CALL wrf_error_fatal ( 'module_dm: mpaspect' )
77      ENDIF
78   RETURN
79   END SUBROUTINE MPASPECT
80
81   SUBROUTINE compute_mesh( ntasks , ntasks_x, ntasks_y )
82     IMPLICIT NONE
83     INTEGER, INTENT(IN)  :: ntasks
84     INTEGER, INTENT(OUT) :: ntasks_x, ntasks_y
85     CALL nl_get_nproc_x ( 1, ntasks_x )
86     CALL nl_get_nproc_y ( 1, ntasks_y )
87! check if user has specified in the namelist
88     IF ( ntasks_x .GT. 0 .OR. ntasks_y .GT. 0 ) THEN
89       ! if only ntasks_x is specified then make it 1-d decomp in i
90       IF      ( ntasks_x .GT. 0 .AND. ntasks_y .EQ. -1 ) THEN
91         ntasks_y = ntasks / ntasks_x
92       ! if only ntasks_y is specified then make it 1-d decomp in j
93       ELSE IF ( ntasks_x .EQ. -1 .AND. ntasks_y .GT. 0 ) THEN
94         ntasks_x = ntasks / ntasks_y
95       ENDIF
96       ! make sure user knows what they're doing
97       IF ( ntasks_x * ntasks_y .NE. ntasks ) THEN
98         WRITE( wrf_err_message , * )'WRF_DM_INITIALIZE (RSL_LITE): nproc_x * nproc_y in namelist ne ',ntasks
99         CALL wrf_error_fatal ( wrf_err_message )
100       ENDIF
101     ELSE
102       ! When neither is specified, work out mesh with MPASPECT
103       ! Pass nproc_ln and nproc_nt so that number of procs in
104       ! i-dim (nproc_ln) is equal or lesser.
105       CALL mpaspect ( ntasks, ntasks_x, ntasks_y, 1, 1 )
106     ENDIF
107   END SUBROUTINE compute_mesh
108
109   SUBROUTINE wrf_dm_initialize
110      IMPLICIT NONE
111#ifndef STUBMPI
112      INCLUDE 'mpif.h'
113      INTEGER :: local_comm, local_comm2, new_local_comm, group, newgroup, p, p1, ierr
114      INTEGER, ALLOCATABLE, DIMENSION(:) :: ranks
115      INTEGER comdup
116      INTEGER, DIMENSION(2) :: dims, coords
117      LOGICAL, DIMENSION(2) :: isperiodic
118      LOGICAL :: reorder_mesh
119
120      CALL wrf_get_dm_communicator ( local_comm )
121      CALL mpi_comm_size( local_comm, ntasks, ierr )
122      CALL nl_get_reorder_mesh( 1, reorder_mesh )
123      CALL compute_mesh( ntasks, ntasks_x, ntasks_y )
124      WRITE( wrf_err_message , * )'Ntasks in X ',ntasks_x,', ntasks in Y ',ntasks_y
125      CALL wrf_message( wrf_err_message )
126
127      CALL mpi_comm_rank( local_comm, mytask, ierr )
128! extra code to reorder the communicator 20051212jm
129      IF ( reorder_mesh ) THEN
130        ALLOCATE (ranks(ntasks))
131        CALL mpi_comm_dup ( local_comm , local_comm2, ierr )
132        CALL mpi_comm_group ( local_comm2, group, ierr )
133        DO p1=1,ntasks
134          p = p1 - 1
135          ranks(p1) = mod( p , ntasks_x ) * ntasks_y + p / ntasks_x 
136        ENDDO
137        CALL mpi_group_incl( group, ntasks, ranks, newgroup, ierr )
138        DEALLOCATE (ranks)
139        CALL mpi_comm_create( local_comm2, newgroup, new_local_comm , ierr )
140      ELSE
141        new_local_comm = local_comm
142      ENDIF
143! end extra code to reorder the communicator 20051212jm
144      dims(1) = ntasks_y  ! rows
145      dims(2) = ntasks_x  ! columns
146      isperiodic(1) = .false.
147      isperiodic(2) = .false.
148      CALL mpi_cart_create( new_local_comm, 2, dims, isperiodic, .false., local_communicator, ierr )
149      dims(1) = ntasks_y  ! rows
150      dims(2) = ntasks_x  ! columns
151      isperiodic(1) = .true.
152      isperiodic(2) = .true.
153      CALL mpi_cart_create( new_local_comm, 2, dims, isperiodic, .false., local_communicator_periodic, ierr )
154! debug
155      CALL mpi_comm_rank( local_communicator_periodic, mytask, ierr )
156      CALL mpi_cart_coords( local_communicator_periodic, mytask, 2, coords, ierr )
157!        write(0,*)'periodic coords ',mytask, coords
158
159      CALL mpi_comm_rank( local_communicator, mytask, ierr )
160      CALL mpi_cart_coords( local_communicator, mytask, 2, coords, ierr )
161!        write(0,*)'non periodic coords ',mytask, coords
162      mytask_x = coords(2)   ! col task (x)
163      mytask_y = coords(1)   ! row task (y)
164      CALL nl_set_nproc_x ( 1, ntasks_x )
165      CALL nl_set_nproc_y ( 1, ntasks_y )
166
167! 20061228 set up subcommunicators for processors in X, Y coords of mesh
168! note that local_comm_x has all the processors in a row (X=0:nproc_x-1);
169! in other words, local_comm_x has all the processes with the same rank in Y
170      CALL MPI_Comm_dup( new_local_comm, comdup, ierr )
171      IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_dup fails in 20061228 mod')
172      CALL MPI_Comm_split(comdup,mytask_y,mytask,local_communicator_x,ierr)
173      IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_split fails for x in 20061228 mod')
174      CALL MPI_Comm_split(comdup,mytask_x,mytask,local_communicator_y,ierr)
175      IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_split fails for y in 20061228 mod')
176! end 20061228
177      CALL wrf_set_dm_communicator ( local_communicator )
178#else
179      ntasks = 1
180      ntasks_x = 1
181      ntasks_y = 1
182      mytask = 0
183      mytask_x = 0
184      mytask_y = 0
185#endif
186
187      RETURN
188   END SUBROUTINE wrf_dm_initialize
189
190   SUBROUTINE get_dm_max_halo_width( id, width )
191     IMPLICIT NONE
192     INTEGER, INTENT(IN) :: id
193     INTEGER, INTENT(OUT) :: width
194     IF ( id .EQ. 1 ) THEN   ! this is coarse domain
195       width = max_halo_width
196     ELSE
197       width = max_halo_width + 3
198     ENDIF
199     RETURN
200   END SUBROUTINE get_dm_max_halo_width
201
202   SUBROUTINE patch_domain_rsl_lite( id  , parent, parent_id, &
203                                sd1 , ed1 , sp1 , ep1 , sm1 , em1 ,        &
204                                sd2 , ed2 , sp2 , ep2 , sm2 , em2 ,        &
205                                sd3 , ed3 , sp3 , ep3 , sm3 , em3 ,        &
206                                      sp1x , ep1x , sm1x , em1x , &
207                                      sp2x , ep2x , sm2x , em2x , &
208                                      sp3x , ep3x , sm3x , em3x , &
209                                      sp1y , ep1y , sm1y , em1y , &
210                                      sp2y , ep2y , sm2y , em2y , &
211                                      sp3y , ep3y , sm3y , em3y , &
212                                bdx , bdy )
213
214      USE module_domain, ONLY : domain, head_grid, find_grid_by_id
215
216      IMPLICIT NONE
217      INTEGER, INTENT(IN)   :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
218      INTEGER, INTENT(OUT)  :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , &
219                               sm1 , em1 , sm2 , em2 , sm3 , em3
220      INTEGER, INTENT(OUT)  :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &
221                               sm1x , em1x , sm2x , em2x , sm3x , em3x
222      INTEGER, INTENT(OUT)  :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &
223                               sm1y , em1y , sm2y , em2y , sm3y , em3y
224      INTEGER, INTENT(IN)   :: id, parent_id
225      TYPE(domain),POINTER  :: parent
226
227! Local variables
228      INTEGER               :: ids, ide, jds, jde, kds, kde
229      INTEGER               :: ims, ime, jms, jme, kms, kme
230      INTEGER               :: ips, ipe, jps, jpe, kps, kpe
231      INTEGER               :: imsx, imex, jmsx, jmex, kmsx, kmex
232      INTEGER               :: ipsx, ipex, jpsx, jpex, kpsx, kpex
233      INTEGER               :: imsy, imey, jmsy, jmey, kmsy, kmey
234      INTEGER               :: ipsy, ipey, jpsy, jpey, kpsy, kpey
235
236      INTEGER               :: c_sd1 , c_ed1 , c_sd2 , c_ed2 , c_sd3 , c_ed3
237      INTEGER               :: c_sp1 , c_ep1 , c_sp2 , c_ep2 , c_sp3 , c_ep3 , &
238                               c_sm1 , c_em1 , c_sm2 , c_em2 , c_sm3 , c_em3
239      INTEGER               :: c_sp1x , c_ep1x , c_sp2x , c_ep2x , c_sp3x , c_ep3x , &
240                               c_sm1x , c_em1x , c_sm2x , c_em2x , c_sm3x , c_em3x
241      INTEGER               :: c_sp1y , c_ep1y , c_sp2y , c_ep2y , c_sp3y , c_ep3y , &
242                               c_sm1y , c_em1y , c_sm2y , c_em2y , c_sm3y , c_em3y
243
244      INTEGER               :: c_ids, c_ide, c_jds, c_jde, c_kds, c_kde
245      INTEGER               :: c_ims, c_ime, c_jms, c_jme, c_kms, c_kme
246      INTEGER               :: c_ips, c_ipe, c_jps, c_jpe, c_kps, c_kpe
247
248      INTEGER               :: idim , jdim , kdim , rem , a, b
249      INTEGER               :: i, j, ni, nj, Px, Py, P
250
251      INTEGER               :: parent_grid_ratio, i_parent_start, j_parent_start
252      INTEGER               :: shw
253      INTEGER               :: idim_cd, jdim_cd, ierr
254      INTEGER               :: max_dom
255
256      TYPE(domain), POINTER :: intermediate_grid
257      TYPE(domain), POINTER  :: nest_grid
258      CHARACTER*256   :: mess
259
260      INTEGER parent_max_halo_width
261      INTEGER thisdomain_max_halo_width
262
263      SELECT CASE ( model_data_order )
264         ! need to finish other cases
265         CASE ( DATA_ORDER_ZXY )
266            ids = sd2 ; ide = ed2
267            jds = sd3 ; jde = ed3
268            kds = sd1 ; kde = ed1
269         CASE ( DATA_ORDER_XYZ )
270            ids = sd1 ; ide = ed1
271            jds = sd2 ; jde = ed2
272            kds = sd3 ; kde = ed3
273         CASE ( DATA_ORDER_XZY )
274            ids = sd1 ; ide = ed1
275            jds = sd3 ; jde = ed3
276            kds = sd2 ; kde = ed2
277         CASE ( DATA_ORDER_YXZ)
278            ids = sd2 ; ide = ed2
279            jds = sd1 ; jde = ed1
280            kds = sd3 ; kde = ed3
281      END SELECT
282
283      CALL nl_get_max_dom( 1 , max_dom )
284
285      CALL get_dm_max_halo_width( id , thisdomain_max_halo_width )
286      IF ( id .GT. 1 ) THEN
287        CALL get_dm_max_halo_width( parent%id , parent_max_halo_width )
288      ENDIF
289
290      CALL compute_memory_dims_rsl_lite ( id, thisdomain_max_halo_width, 0 , bdx, bdy,   &
291                   ids,  ide,  jds,  jde,  kds,  kde, &
292                   ims,  ime,  jms,  jme,  kms,  kme, &
293                   imsx, imex, jmsx, jmex, kmsx, kmex, &
294                   imsy, imey, jmsy, jmey, kmsy, kmey, &
295                   ips,  ipe,  jps,  jpe,  kps,  kpe, &
296                   ipsx, ipex, jpsx, jpex, kpsx, kpex, &
297                   ipsy, ipey, jpsy, jpey, kpsy, kpey )
298
299     ! ensure that the every parent domain point has a full set of nested points under it
300     ! even at the borders. Do this by making sure the number of nest points is a multiple of
301     ! the nesting ratio. Note that this is important mostly to the intermediate domain, which
302     ! is the subject of the scatter gather comms with the parent
303
304      IF ( id .GT. 1 ) THEN
305         CALL nl_get_parent_grid_ratio( id, parent_grid_ratio )
306         if ( mod(ime,parent_grid_ratio) .NE. 0 ) ime = ime + parent_grid_ratio - mod(ime,parent_grid_ratio)
307         if ( mod(jme,parent_grid_ratio) .NE. 0 ) jme = jme + parent_grid_ratio - mod(jme,parent_grid_ratio)
308      ENDIF
309
310      SELECT CASE ( model_data_order )
311         CASE ( DATA_ORDER_ZXY )
312            sp2 = ips ; ep2 = ipe ; sm2 = ims ; em2 = ime
313            sp3 = jps ; ep3 = jpe ; sm3 = jms ; em3 = jme
314            sp1 = kps ; ep1 = kpe ; sm1 = kms ; em1 = kme
315            sp2x = ipsx ; ep2x = ipex ; sm2x = imsx ; em2x = imex
316            sp3x = jpsx ; ep3x = jpex ; sm3x = jmsx ; em3x = jmex
317            sp1x = kpsx ; ep1x = kpex ; sm1x = kmsx ; em1x = kmex
318            sp2y = ipsy ; ep2y = ipey ; sm2y = imsy ; em2y = imey
319            sp3y = jpsy ; ep3y = jpey ; sm3y = jmsy ; em3y = jmey
320            sp1y = kpsy ; ep1y = kpey ; sm1y = kmsy ; em1y = kmey
321         CASE ( DATA_ORDER_ZYX )
322            sp3 = ips ; ep3 = ipe ; sm3 = ims ; em3 = ime
323            sp2 = jps ; ep2 = jpe ; sm2 = jms ; em2 = jme
324            sp1 = kps ; ep1 = kpe ; sm1 = kms ; em1 = kme
325            sp3x = ipsx ; ep3x = ipex ; sm3x = imsx ; em3x = imex
326            sp2x = jpsx ; ep2x = jpex ; sm2x = jmsx ; em2x = jmex
327            sp1x = kpsx ; ep1x = kpex ; sm1x = kmsx ; em1x = kmex
328            sp3y = ipsy ; ep3y = ipey ; sm3y = imsy ; em3y = imey
329            sp2y = jpsy ; ep2y = jpey ; sm2y = jmsy ; em2y = jmey
330            sp1y = kpsy ; ep1y = kpey ; sm1y = kmsy ; em1y = kmey
331         CASE ( DATA_ORDER_XYZ )
332            sp1 = ips ; ep1 = ipe ; sm1 = ims ; em1 = ime
333            sp2 = jps ; ep2 = jpe ; sm2 = jms ; em2 = jme
334            sp3 = kps ; ep3 = kpe ; sm3 = kms ; em3 = kme
335            sp1x = ipsx ; ep1x = ipex ; sm1x = imsx ; em1x = imex
336            sp2x = jpsx ; ep2x = jpex ; sm2x = jmsx ; em2x = jmex
337            sp3x = kpsx ; ep3x = kpex ; sm3x = kmsx ; em3x = kmex
338            sp1y = ipsy ; ep1y = ipey ; sm1y = imsy ; em1y = imey
339            sp2y = jpsy ; ep2y = jpey ; sm2y = jmsy ; em2y = jmey
340            sp3y = kpsy ; ep3y = kpey ; sm3y = kmsy ; em3y = kmey
341         CASE ( DATA_ORDER_YXZ)
342            sp2 = ips ; ep2 = ipe ; sm2 = ims ; em2 = ime
343            sp1 = jps ; ep1 = jpe ; sm1 = jms ; em1 = jme
344            sp3 = kps ; ep3 = kpe ; sm3 = kms ; em3 = kme
345            sp2x = ipsx ; ep2x = ipex ; sm2x = imsx ; em2x = imex
346            sp1x = jpsx ; ep1x = jpex ; sm1x = jmsx ; em1x = jmex
347            sp3x = kpsx ; ep3x = kpex ; sm3x = kmsx ; em3x = kmex
348            sp2y = ipsy ; ep2y = ipey ; sm2y = imsy ; em2y = imey
349            sp1y = jpsy ; ep1y = jpey ; sm1y = jmsy ; em1y = jmey
350            sp3y = kpsy ; ep3y = kpey ; sm3y = kmsy ; em3y = kmey
351         CASE ( DATA_ORDER_XZY )
352            sp1 = ips ; ep1 = ipe ; sm1 = ims ; em1 = ime
353            sp3 = jps ; ep3 = jpe ; sm3 = jms ; em3 = jme
354            sp2 = kps ; ep2 = kpe ; sm2 = kms ; em2 = kme
355            sp1x = ipsx ; ep1x = ipex ; sm1x = imsx ; em1x = imex
356            sp3x = jpsx ; ep3x = jpex ; sm3x = jmsx ; em3x = jmex
357            sp2x = kpsx ; ep2x = kpex ; sm2x = kmsx ; em2x = kmex
358            sp1y = ipsy ; ep1y = ipey ; sm1y = imsy ; em1y = imey
359            sp3y = jpsy ; ep3y = jpey ; sm3y = jmsy ; em3y = jmey
360            sp2y = kpsy ; ep2y = kpey ; sm2y = kmsy ; em2y = kmey
361         CASE ( DATA_ORDER_YZX )
362            sp3 = ips ; ep3 = ipe ; sm3 = ims ; em3 = ime
363            sp1 = jps ; ep1 = jpe ; sm1 = jms ; em1 = jme
364            sp2 = kps ; ep2 = kpe ; sm2 = kms ; em2 = kme
365            sp3x = ipsx ; ep3x = ipex ; sm3x = imsx ; em3x = imex
366            sp1x = jpsx ; ep1x = jpex ; sm1x = jmsx ; em1x = jmex
367            sp2x = kpsx ; ep2x = kpex ; sm2x = kmsx ; em2x = kmex
368            sp3y = ipsy ; ep3y = ipey ; sm3y = imsy ; em3y = imey
369            sp1y = jpsy ; ep1y = jpey ; sm1y = jmsy ; em1y = jmey
370            sp2y = kpsy ; ep2y = kpey ; sm2y = kmsy ; em2y = kmey
371      END SELECT
372
373      IF ( id.EQ.1 ) THEN
374         WRITE(wrf_err_message,*)'*************************************'
375         CALL wrf_message( TRIM(wrf_err_message) )
376         WRITE(wrf_err_message,*)'Parent domain'
377         CALL wrf_message( TRIM(wrf_err_message) )
378         WRITE(wrf_err_message,*)'ids,ide,jds,jde ',ids,ide,jds,jde
379         CALL wrf_message( TRIM(wrf_err_message) )
380         WRITE(wrf_err_message,*)'ims,ime,jms,jme ',ims,ime,jms,jme
381         CALL wrf_message( TRIM(wrf_err_message) )
382         WRITE(wrf_err_message,*)'ips,ipe,jps,jpe ',ips,ipe,jps,jpe
383         CALL wrf_message( TRIM(wrf_err_message) )
384         WRITE(wrf_err_message,*)'*************************************'
385         CALL wrf_message( TRIM(wrf_err_message) )
386      ENDIF
387
388      IF ( id .GT. 1 ) THEN
389
390         CALL nl_get_shw( id, shw )
391         CALL nl_get_i_parent_start( id , i_parent_start )
392         CALL nl_get_j_parent_start( id , j_parent_start )
393         CALL nl_get_parent_grid_ratio( id, parent_grid_ratio )
394
395         SELECT CASE ( model_data_order )
396            CASE ( DATA_ORDER_ZXY )
397               idim = ed2-sd2+1
398               jdim = ed3-sd3+1
399               kdim = ed1-sd1+1
400               c_kds = sd1                ; c_kde = ed1
401            CASE ( DATA_ORDER_ZYX )
402               idim = ed3-sd3+1
403               jdim = ed2-sd2+1
404               kdim = ed1-sd1+1
405               c_kds = sd1                ; c_kde = ed1
406            CASE ( DATA_ORDER_XYZ )
407               idim = ed1-sd1+1
408               jdim = ed2-sd2+1
409               kdim = ed3-sd3+1
410               c_kds = sd3                ; c_kde = ed3
411            CASE ( DATA_ORDER_YXZ)
412               idim = ed2-sd2+1
413               jdim = ed1-sd1+1
414               kdim = ed3-sd3+1
415               c_kds = sd3                ; c_kde = ed3
416            CASE ( DATA_ORDER_XZY )
417               idim = ed1-sd1+1
418               jdim = ed3-sd3+1
419               kdim = ed2-sd2+1
420               c_kds = sd2                ; c_kde = ed2
421            CASE ( DATA_ORDER_YZX )
422               idim = ed3-sd3+1
423               jdim = ed1-sd1+1
424               kdim = ed2-sd2+1
425               c_kds = sd2                ; c_kde = ed2
426         END SELECT
427
428         idim_cd = idim / parent_grid_ratio + 1 + 2*shw + 1
429         jdim_cd = jdim / parent_grid_ratio + 1 + 2*shw + 1
430
431         c_ids = i_parent_start-shw ; c_ide = c_ids + idim_cd - 1
432         c_jds = j_parent_start-shw ; c_jde = c_jds + jdim_cd - 1
433
434         ! we want the intermediate domain to be decomposed the
435         ! the same as the underlying nest. So try this:
436
437         c_ips = -1
438         nj = ( c_jds - j_parent_start ) * parent_grid_ratio + 1 + 1 ;
439         ierr = 0
440         DO i = c_ids, c_ide
441            ni = ( i - i_parent_start ) * parent_grid_ratio + 1 + 1 ;
442            CALL task_for_point ( ni, nj, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
443                                  1, 1,  ierr )
444            IF ( Px .EQ. mytask_x ) THEN
445               c_ipe = i
446               IF ( c_ips .EQ. -1 ) c_ips = i
447            ENDIF
448         ENDDO
449         IF ( ierr .NE. 0 ) THEN
450            CALL tfp_message(__FILE__,__LINE__)
451         ENDIF
452         IF (c_ips .EQ. -1 ) THEN
453            c_ipe = -1
454            c_ips = 0
455         ENDIF
456
457         c_jps = -1
458         ni = ( c_ids - i_parent_start ) * parent_grid_ratio + 1 + 1 ;
459         ierr = 0
460         DO j = c_jds, c_jde
461            nj = ( j - j_parent_start ) * parent_grid_ratio + 1 + 1 ;
462            CALL task_for_point ( ni, nj, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
463                                  1, 1, ierr )
464
465
466            IF ( Py .EQ. mytask_y ) THEN
467               c_jpe = j
468               IF ( c_jps .EQ. -1 ) c_jps = j
469            ENDIF
470         ENDDO
471         IF ( ierr .NE. 0 ) THEN
472            CALL tfp_message(__FILE__,__LINE__)
473         ENDIF
474         IF (c_jps .EQ. -1 ) THEN
475            c_jpe = -1
476            c_jps = 0
477         ENDIF
478
479         IF ( c_ips <= c_ipe ) THEN
480! extend the patch dimensions out shw along edges of domain
481           IF ( mytask_x .EQ. 0 ) THEN
482             c_ips = c_ips - shw
483           ENDIF
484           IF ( mytask_x .EQ. ntasks_x-1 ) THEN
485             c_ipe = c_ipe + shw
486           ENDIF
487           c_ims = max( c_ips - max(shw,thisdomain_max_halo_width), c_ids - bdx ) - 1
488           c_ime = min( c_ipe + max(shw,thisdomain_max_halo_width), c_ide + bdx ) + 1
489         ELSE
490           c_ims = 0
491           c_ime = 0
492         ENDIF
493
494
495! handle j dims
496         IF ( c_jps <= c_jpe ) THEN
497! extend the patch dimensions out shw along edges of domain
498           IF ( mytask_y .EQ. 0 ) THEN
499              c_jps = c_jps - shw
500           ENDIF
501           IF ( mytask_y .EQ. ntasks_y-1 ) THEN
502              c_jpe = c_jpe + shw
503           ENDIF
504           c_jms = max( c_jps - max(shw,thisdomain_max_halo_width), c_jds - bdx ) - 1
505           c_jme = min( c_jpe + max(shw,thisdomain_max_halo_width), c_jde + bdx ) + 1
506! handle k dims
507         ELSE
508           c_jms = 0
509           c_jme = 0
510         ENDIF
511         c_kps = 1
512         c_kpe = c_kde
513         c_kms = 1
514         c_kme = c_kde
515
516         WRITE(wrf_err_message,*)'*************************************'
517         CALL wrf_message( TRIM(wrf_err_message) )
518         WRITE(wrf_err_message,*)'Nesting domain'
519         CALL wrf_message( TRIM(wrf_err_message) )
520         WRITE(wrf_err_message,*)'ids,ide,jds,jde ',ids,ide,jds,jde
521         CALL wrf_message( TRIM(wrf_err_message) )
522         WRITE(wrf_err_message,*)'ims,ime,jms,jme ',ims,ime,jms,jme
523         CALL wrf_message( TRIM(wrf_err_message) )
524         WRITE(wrf_err_message,*)'ips,ipe,jps,jpe ',ips,ipe,jps,jpe
525         CALL wrf_message( TRIM(wrf_err_message) )
526         WRITE(wrf_err_message,*)'INTERMEDIATE domain'
527         CALL wrf_message( TRIM(wrf_err_message) )
528         WRITE(wrf_err_message,*)'ids,ide,jds,jde ',c_ids,c_ide,c_jds,c_jde
529         CALL wrf_message( TRIM(wrf_err_message) )
530         WRITE(wrf_err_message,*)'ims,ime,jms,jme ',c_ims,c_ime,c_jms,c_jme
531         CALL wrf_message( TRIM(wrf_err_message) )
532         WRITE(wrf_err_message,*)'ips,ipe,jps,jpe ',c_ips,c_ipe,c_jps,c_jpe
533         CALL wrf_message( TRIM(wrf_err_message) )
534         WRITE(wrf_err_message,*)'*************************************'
535         CALL wrf_message( TRIM(wrf_err_message) )
536
537         SELECT CASE ( model_data_order )
538            CASE ( DATA_ORDER_ZXY )
539               c_sd2 = c_ids ; c_ed2 = c_ide ; c_sp2 = c_ips ; c_ep2 = c_ipe ; c_sm2 = c_ims ; c_em2 = c_ime
540               c_sd3 = c_jds ; c_ed3 = c_jde ; c_sp3 = c_jps ; c_ep3 = c_jpe ; c_sm3 = c_jms ; c_em3 = c_jme
541               c_sd1 = c_kds ; c_ed1 = c_kde ; c_sp1 = c_kps ; c_ep1 = c_kpe ; c_sm1 = c_kms ; c_em1 = c_kme
542            CASE ( DATA_ORDER_ZYX )
543               c_sd3 = c_ids ; c_ed3 = c_ide ; c_sp3 = c_ips ; c_ep3 = c_ipe ; c_sm3 = c_ims ; c_em3 = c_ime
544               c_sd2 = c_jds ; c_ed2 = c_jde ; c_sp2 = c_jps ; c_ep2 = c_jpe ; c_sm2 = c_jms ; c_em2 = c_jme
545               c_sd1 = c_kds ; c_ed1 = c_kde ; c_sp1 = c_kps ; c_ep1 = c_kpe ; c_sm1 = c_kms ; c_em1 = c_kme
546            CASE ( DATA_ORDER_XYZ )
547               c_sd1 = c_ids ; c_ed1 = c_ide ; c_sp1 = c_ips ; c_ep1 = c_ipe ; c_sm1 = c_ims ; c_em1 = c_ime
548               c_sd2 = c_jds ; c_ed2 = c_jde ; c_sp2 = c_jps ; c_ep2 = c_jpe ; c_sm2 = c_jms ; c_em2 = c_jme
549               c_sd3 = c_kds ; c_ed3 = c_kde ; c_sp3 = c_kps ; c_ep3 = c_kpe ; c_sm3 = c_kms ; c_em3 = c_kme
550            CASE ( DATA_ORDER_YXZ)
551               c_sd2 = c_ids ; c_ed2 = c_ide ; c_sp2 = c_ips ; c_ep2 = c_ipe ; c_sm2 = c_ims ; c_em2 = c_ime
552               c_sd1 = c_jds ; c_ed1 = c_jde ; c_sp1 = c_jps ; c_ep1 = c_jpe ; c_sm1 = c_jms ; c_em1 = c_jme
553               c_sd3 = c_kds ; c_ed3 = c_kde ; c_sp3 = c_kps ; c_ep3 = c_kpe ; c_sm3 = c_kms ; c_em3 = c_kme
554            CASE ( DATA_ORDER_XZY )
555               c_sd1 = c_ids ; c_ed1 = c_ide ; c_sp1 = c_ips ; c_ep1 = c_ipe ; c_sm1 = c_ims ; c_em1 = c_ime
556               c_sd3 = c_jds ; c_ed3 = c_jde ; c_sp3 = c_jps ; c_ep3 = c_jpe ; c_sm3 = c_jms ; c_em3 = c_jme
557               c_sd2 = c_kds ; c_ed2 = c_kde ; c_sp2 = c_kps ; c_ep2 = c_kpe ; c_sm2 = c_kms ; c_em2 = c_kme
558            CASE ( DATA_ORDER_YZX )
559               c_sd3 = c_ids ; c_ed3 = c_ide ; c_sp3 = c_ips ; c_ep3 = c_ipe ; c_sm3 = c_ims ; c_em3 = c_ime
560               c_sd1 = c_jds ; c_ed1 = c_jde ; c_sp1 = c_jps ; c_ep1 = c_jpe ; c_sm1 = c_jms ; c_em1 = c_jme
561               c_sd2 = c_kds ; c_ed2 = c_kde ; c_sp2 = c_kps ; c_ep2 = c_kpe ; c_sm2 = c_kms ; c_em2 = c_kme
562         END SELECT
563
564         ALLOCATE ( intermediate_grid )
565         ALLOCATE ( intermediate_grid%parents( max_parents ) )
566         ALLOCATE ( intermediate_grid%nests( max_nests ) )
567         intermediate_grid%allocated=.false.
568         NULLIFY( intermediate_grid%sibling )
569         DO i = 1, max_nests
570            NULLIFY( intermediate_grid%nests(i)%ptr )
571         ENDDO
572         NULLIFY  (intermediate_grid%next)
573         NULLIFY  (intermediate_grid%same_level)
574         NULLIFY  (intermediate_grid%i_start)
575         NULLIFY  (intermediate_grid%j_start)
576         NULLIFY  (intermediate_grid%i_end)
577         NULLIFY  (intermediate_grid%j_end)
578         intermediate_grid%id = id   ! these must be the same. Other parts of code depend on it (see gen_comms.c)
579         intermediate_grid%num_nests = 0
580         intermediate_grid%num_siblings = 0
581         intermediate_grid%num_parents = 1
582         intermediate_grid%max_tiles   = 0
583         intermediate_grid%num_tiles_spec   = 0
584         CALL find_grid_by_id ( id, head_grid, nest_grid )
585
586         nest_grid%intermediate_grid => intermediate_grid  ! nest grid now has a pointer to this baby
587         intermediate_grid%parents(1)%ptr => nest_grid     ! the intermediate grid considers nest its parent
588         intermediate_grid%num_parents = 1
589
590         intermediate_grid%is_intermediate = .TRUE.
591         SELECT CASE ( model_data_order )
592            CASE ( DATA_ORDER_ZXY )
593               intermediate_grid%nids = nest_grid%sd32 ; intermediate_grid%njds = nest_grid%sd33
594               intermediate_grid%nide = nest_grid%ed32 ; intermediate_grid%njde = nest_grid%sd33
595            CASE ( DATA_ORDER_ZYX )
596               intermediate_grid%nids = nest_grid%sd33 ; intermediate_grid%njds = nest_grid%sd32
597               intermediate_grid%nide = nest_grid%ed33 ; intermediate_grid%njde = nest_grid%sd32
598            CASE ( DATA_ORDER_XYZ )
599               intermediate_grid%nids = nest_grid%sd31 ; intermediate_grid%njds = nest_grid%sd32
600               intermediate_grid%nide = nest_grid%ed31 ; intermediate_grid%njde = nest_grid%sd32
601            CASE ( DATA_ORDER_YXZ)
602               intermediate_grid%nids = nest_grid%sd32 ; intermediate_grid%njds = nest_grid%sd31
603               intermediate_grid%nide = nest_grid%ed32 ; intermediate_grid%njde = nest_grid%sd31
604            CASE ( DATA_ORDER_XZY )
605               intermediate_grid%nids = nest_grid%sd31 ; intermediate_grid%njds = nest_grid%sd33
606               intermediate_grid%nide = nest_grid%ed31 ; intermediate_grid%njde = nest_grid%sd33
607            CASE ( DATA_ORDER_YZX )
608               intermediate_grid%nids = nest_grid%sd33 ; intermediate_grid%njds = nest_grid%sd31
609               intermediate_grid%nide = nest_grid%ed33 ; intermediate_grid%njde = nest_grid%sd31
610         END SELECT
611         intermediate_grid%nids = ids
612         intermediate_grid%nide = ide
613         intermediate_grid%njds = jds
614         intermediate_grid%njde = jde
615
616         c_sm1x = 1 ; c_em1x = 1 ; c_sm2x = 1 ; c_em2x = 1 ; c_sm3x = 1 ; c_em3x = 1
617         c_sm1y = 1 ; c_em1y = 1 ; c_sm2y = 1 ; c_em2y = 1 ; c_sm3y = 1 ; c_em3y = 1
618
619         intermediate_grid%sm31x                           = c_sm1x
620         intermediate_grid%em31x                           = c_em1x
621         intermediate_grid%sm32x                           = c_sm2x
622         intermediate_grid%em32x                           = c_em2x
623         intermediate_grid%sm33x                           = c_sm3x
624         intermediate_grid%em33x                           = c_em3x
625         intermediate_grid%sm31y                           = c_sm1y
626         intermediate_grid%em31y                           = c_em1y
627         intermediate_grid%sm32y                           = c_sm2y
628         intermediate_grid%em32y                           = c_em2y
629         intermediate_grid%sm33y                           = c_sm3y
630         intermediate_grid%em33y                           = c_em3y
631
632#if defined(SGIALTIX) && (! defined(MOVE_NESTS) )
633         ! allocate space for the intermediate domain
634         CALL alloc_space_field ( intermediate_grid, intermediate_grid%id , 1, 2 , .TRUE., &   ! use same id as nest
635                               c_sd1, c_ed1, c_sd2, c_ed2, c_sd3, c_ed3,       &
636                               c_sm1,  c_em1,  c_sm2,  c_em2,  c_sm3,  c_em3,  &
637                               c_sm1x, c_em1x, c_sm2x, c_em2x, c_sm3x, c_em3x, &
638                               c_sm1y, c_em1y, c_sm2y, c_em2y, c_sm3y, c_em3y, &
639                               c_sm1x, c_em1x, c_sm2x, c_em2x, c_sm3x, c_em3x, &   ! x-xpose
640                               c_sm1y, c_em1y, c_sm2y, c_em2y, c_sm3y, c_em3y  )   ! y-xpose
641#endif
642         intermediate_grid%sd31                            =   c_sd1
643         intermediate_grid%ed31                            =   c_ed1
644         intermediate_grid%sp31                            = c_sp1
645         intermediate_grid%ep31                            = c_ep1
646         intermediate_grid%sm31                            = c_sm1
647         intermediate_grid%em31                            = c_em1
648         intermediate_grid%sd32                            =   c_sd2
649         intermediate_grid%ed32                            =   c_ed2
650         intermediate_grid%sp32                            = c_sp2
651         intermediate_grid%ep32                            = c_ep2
652         intermediate_grid%sm32                            = c_sm2
653         intermediate_grid%em32                            = c_em2
654         intermediate_grid%sd33                            =   c_sd3
655         intermediate_grid%ed33                            =   c_ed3
656         intermediate_grid%sp33                            = c_sp3
657         intermediate_grid%ep33                            = c_ep3
658         intermediate_grid%sm33                            = c_sm3
659         intermediate_grid%em33                            = c_em3
660
661         CALL med_add_config_info_to_grid ( intermediate_grid )
662
663         intermediate_grid%dx = parent%dx
664         intermediate_grid%dy = parent%dy
665         intermediate_grid%dt = parent%dt
666      ENDIF
667
668      RETURN
669  END SUBROUTINE patch_domain_rsl_lite
670
671  SUBROUTINE compute_memory_dims_rsl_lite  (      &
672                   id , maxhalowidth ,            &
673                   shw , bdx,  bdy ,              &
674                   ids,  ide,  jds,  jde,  kds,  kde, &
675                   ims,  ime,  jms,  jme,  kms,  kme, &
676                   imsx, imex, jmsx, jmex, kmsx, kmex, &
677                   imsy, imey, jmsy, jmey, kmsy, kmey, &
678                   ips,  ipe,  jps,  jpe,  kps,  kpe, &
679                   ipsx, ipex, jpsx, jpex, kpsx, kpex, &
680                   ipsy, ipey, jpsy, jpey, kpsy, kpey )
681
682    IMPLICIT NONE
683    INTEGER, INTENT(IN)               ::  id , maxhalowidth
684    INTEGER, INTENT(IN)               ::  shw, bdx, bdy
685    INTEGER, INTENT(IN)     ::  ids, ide, jds, jde, kds, kde
686    INTEGER, INTENT(OUT)    ::  ims, ime, jms, jme, kms, kme
687    INTEGER, INTENT(OUT)    ::  imsx, imex, jmsx, jmex, kmsx, kmex
688    INTEGER, INTENT(OUT)    ::  imsy, imey, jmsy, jmey, kmsy, kmey
689    INTEGER, INTENT(OUT)    ::  ips, ipe, jps, jpe, kps, kpe
690    INTEGER, INTENT(OUT)    ::  ipsx, ipex, jpsx, jpex, kpsx, kpex
691    INTEGER, INTENT(OUT)    ::  ipsy, ipey, jpsy, jpey, kpsy, kpey
692
693    INTEGER Px, Py, P, i, j, k, ierr
694
695#if ( ! NMM_CORE == 1 )
696
697! xy decomposition
698
699    ips = -1
700    j = jds
701    ierr = 0
702    DO i = ids, ide
703       CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
704                             1, 1, ierr )
705       IF ( Px .EQ. mytask_x ) THEN
706          ipe = i
707          IF ( ips .EQ. -1 ) ips = i
708       ENDIF
709    ENDDO
710    IF ( ierr .NE. 0 ) THEN
711       CALL tfp_message(__FILE__,__LINE__)
712    ENDIF
713    ! handle setting the memory dimensions where there are no X elements assigned to this proc
714    IF (ips .EQ. -1 ) THEN
715       ipe = -1
716       ips = 0
717    ENDIF
718    jps = -1
719    i = ids
720    ierr = 0
721    DO j = jds, jde
722       CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
723                             1, 1, ierr )
724       IF ( Py .EQ. mytask_y ) THEN
725          jpe = j
726          IF ( jps .EQ. -1 ) jps = j
727       ENDIF
728    ENDDO
729    IF ( ierr .NE. 0 ) THEN
730       CALL tfp_message(__FILE__,__LINE__)
731    ENDIF
732    ! handle setting the memory dimensions where there are no Y elements assigned to this proc
733    IF (jps .EQ. -1 ) THEN
734       jpe = -1
735       jps = 0
736    ENDIF
737
738!begin: wig; 12-Mar-2008
739! This appears redundant with the conditionals above, but we get cases with only
740! one of the directions being set to "missing" when turning off extra processors.
741! This may break the handling of setting only one of nproc_x or nproc_y via the namelist.
742    IF (ipe .EQ. -1 .or. jpe .EQ. -1) THEN
743       ipe = -1
744       ips = 0
745       jpe = -1
746       jps = 0
747    ENDIF
748!end: wig; 12-Mar-2008
749
750!
751! description of transpose decomposition strategy for RSL LITE. 20061231jm
752!
753! Here is the tranpose scheme that is implemented for RSL_LITE. Upper-case
754! XY corresponds to the dimension of the processor mesh, lower-case xyz
755! corresponds to grid dimension.
756!
757!      xy        zy        zx
758!
759!     XxYy <--> XzYy <--> XzYx <- note x decomposed over Y procs
760!       ^                  ^
761!       |                  |
762!       +------------------+  <- this edge is costly; see below
763!
764! The aim is to avoid all-to-all communication over whole
765! communicator. Instead, when possible, use a transpose scheme that requires
766! all-to-all within dimensional communicators; that is, communicators
767! defined for the processes in a rank or column of the processor mesh. Note,
768! however, it is not possible to create a ring of transposes between
769! xy-yz-xz decompositions without at least one of the edges in the ring
770! being fully all-to-all (in other words, one of the tranpose edges must
771! rotate and not just transpose a plane of the model grid within the
772! processor mesh). The issue is then, where should we put this costly edge
773! in the tranpose scheme we chose? To avoid being completely arbitrary,
774! we chose a scheme most natural for models that use parallel spectral
775! transforms, where the costly edge is the one that goes from the xz to
776! the xy decomposition.  (May be implemented as just a two step transpose
777! back through yz).
778!
779! Additional notational convention, below. The 'x' or 'y' appended to the
780! dimension start or end variable refers to which grid dimension is all
781! on-processor in the given decomposition. That is ipsx and ipex are the
782! start and end for the i-dimension in the zy decomposition where x is
783! on-processor. ('z' is assumed for xy decomposition and not appended to
784! the ips, ipe, etc. variable names).
785!
786
787! XzYy decomposition
788
789    kpsx = -1
790    j = jds ;
791    ierr = 0
792    DO k = kds, kde
793       CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, &
794                             1, 1, ierr )
795       IF ( Px .EQ. mytask_x ) THEN
796          kpex = k
797          IF ( kpsx .EQ. -1 ) kpsx = k
798       ENDIF
799    ENDDO
800    IF ( ierr .NE. 0 ) THEN
801       CALL tfp_message(__FILE__,__LINE__)
802    ENDIF
803   
804! handle case where no levels are assigned to this process
805! no iterations.  Do same for I and J. Need to handle memory alloc below.
806    IF (kpsx .EQ. -1 ) THEN
807       kpex = -1
808       kpsx = 0
809    ENDIF
810
811    jpsx = -1
812    k = kds ;
813    ierr = 0
814    DO j = jds, jde
815       CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, &
816                             1, 1, ierr )
817       IF ( Py .EQ. mytask_y ) THEN
818          jpex = j
819          IF ( jpsx .EQ. -1 ) jpsx = j
820       ENDIF
821    ENDDO
822    IF ( ierr .NE. 0 ) THEN
823       CALL tfp_message(__FILE__,__LINE__)
824    ENDIF
825    IF (jpsx .EQ. -1 ) THEN
826       jpex = -1
827       jpsx = 0
828    ENDIF
829
830!begin: wig; 12-Mar-2008
831! This appears redundant with the conditionals above, but we get cases with only
832! one of the directions being set to "missing" when turning off extra processors.
833! This may break the handling of setting only one of nproc_x or nproc_y via the namelist.
834    IF (ipex .EQ. -1 .or. jpex .EQ. -1) THEN
835       ipex = -1
836       ipsx = 0
837       jpex = -1
838       jpsx = 0
839    ENDIF
840!end: wig; 12-Mar-2008
841
842! XzYx decomposition  (note, x grid dim is decomposed over Y processor dim)
843
844    kpsy = kpsx   ! same as above
845    kpey = kpex   ! same as above
846
847    ipsy = -1
848    k = kds ;
849    ierr = 0
850    DO i = ids, ide
851       CALL task_for_point ( i, k, ids, ide, kds, kde, ntasks_y, ntasks_x, Py, Px, &
852                             1, 1, ierr ) ! x and y for proc mesh reversed
853       IF ( Py .EQ. mytask_y ) THEN
854          ipey = i
855          IF ( ipsy .EQ. -1 ) ipsy = i
856       ENDIF
857    ENDDO
858    IF ( ierr .NE. 0 ) THEN
859       CALL tfp_message(__FILE__,__LINE__)
860    ENDIF
861    IF (ipsy .EQ. -1 ) THEN
862       ipey = -1
863       ipsy = 0
864    ENDIF
865
866
867#else
868
869! In case of NMM CORE, the domain only ever runs from ids..ide-1 and jds..jde-1 so
870! adjust decomposition to reflect.  20051020 JM
871    ips = -1
872    j = jds
873    ierr = 0
874    DO i = ids, ide-1
875       CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, &
876                             1, 1 , ierr )
877       IF ( Px .EQ. mytask_x ) THEN
878          ipe = i
879          IF ( Px .EQ. ntasks_x-1 ) ipe = ipe + 1
880          IF ( ips .EQ. -1 ) ips = i
881       ENDIF
882    ENDDO
883    IF ( ierr .NE. 0 ) THEN
884       CALL tfp_message(__FILE__,__LINE__)
885    ENDIF
886    jps = -1
887    i = ids ;
888    ierr = 0
889    DO j = jds, jde-1
890       CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, &
891                             1 , 1 , ierr )
892       IF ( Py .EQ. mytask_y ) THEN
893          jpe = j
894          IF ( Py .EQ. ntasks_y-1 ) jpe = jpe + 1
895          IF ( jps .EQ. -1 ) jps = j
896       ENDIF
897    ENDDO
898    IF ( ierr .NE. 0 ) THEN
899       CALL tfp_message(__FILE__,__LINE__)
900    ENDIF
901#endif
902
903! extend the patch dimensions out shw along edges of domain
904    IF ( ips < ipe .and. jps < jpe ) THEN           !wig; 11-Mar-2008
905       IF ( mytask_x .EQ. 0 ) THEN
906          ips = ips - shw
907          ipsy = ipsy - shw
908       ENDIF
909       IF ( mytask_x .EQ. ntasks_x-1 ) THEN
910          ipe = ipe + shw
911          ipey = ipey + shw
912       ENDIF
913       IF ( mytask_y .EQ. 0 ) THEN
914          jps = jps - shw
915          jpsx = jpsx - shw
916       ENDIF
917       IF ( mytask_y .EQ. ntasks_y-1 ) THEN
918          jpe = jpe + shw
919          jpex = jpex + shw
920       ENDIF
921    ENDIF                                           !wig; 11-Mar-2008
922
923    kps = 1
924    kpe = kde-kds+1
925
926    kms = 1
927    kme = kpe
928    kmsx = kpsx
929    kmex = kpex
930    kmsy = kpsy
931    kmey = kpey
932
933    ! handle setting the memory dimensions where there are no levels assigned to this proc
934    IF ( kpsx .EQ. 0 .AND. kpex .EQ. -1 ) THEN
935      kmsx = 0
936      kmex = 0
937    ENDIF
938    IF ( kpsy .EQ. 0 .AND. kpey .EQ. -1 ) THEN
939      kmsy = 0
940      kmey = 0
941    ENDIF
942
943    IF ( (jps .EQ. 0 .AND. jpe .EQ. -1) .OR. (ips .EQ. 0 .AND. ipe .EQ. -1) ) THEN
944      ims = 0
945      ime = 0
946    ELSE
947      ims = max( ips - max(shw,maxhalowidth), ids - bdx ) - 1
948      ime = min( ipe + max(shw,maxhalowidth), ide + bdx ) + 1
949    ENDIF
950    imsx = ids
951    imex = ide
952    ipsx = imsx
953    ipex = imex
954    ! handle setting the memory dimensions where there are no Y elements assigned to this proc
955    IF ( ipsy .EQ. 0 .AND. ipey .EQ. -1 ) THEN
956      imsy = 0
957      imey = 0
958    ELSE
959      imsy = ipsy
960      imey = ipey
961    ENDIF
962
963    IF ( (jps .EQ. 0 .AND. jpe .EQ. -1) .OR. (ips .EQ. 0 .AND. ipe .EQ. -1) ) THEN
964      jms = 0
965      jme = 0
966    ELSE
967      jms = max( jps - max(shw,maxhalowidth), jds - bdy ) - 1
968      jme = min( jpe + max(shw,maxhalowidth), jde + bdy ) + 1
969    ENDIF
970    jmsx = jpsx
971    jmex = jpex
972    jmsy = jds
973    jmey = jde
974    ! handle setting the memory dimensions where there are no X elements assigned to this proc
975    IF ( jpsx .EQ. 0 .AND. jpex .EQ. -1 ) THEN
976      jmsx = 0
977      jmex = 0
978    ELSE
979      jpsy = jmsy
980      jpey = jmey
981    ENDIF
982
983  END SUBROUTINE compute_memory_dims_rsl_lite
984
985! internal, used below for switching the argument to MPI calls
986! if reals are being autopromoted to doubles in the build of WRF
987   INTEGER function getrealmpitype()
988#ifndef STUBMPI
989      IMPLICIT NONE
990      INCLUDE 'mpif.h'
991      INTEGER rtypesize, dtypesize, ierr
992      CALL mpi_type_size ( MPI_REAL, rtypesize, ierr )
993      CALL mpi_type_size ( MPI_DOUBLE_PRECISION, dtypesize, ierr )
994      IF ( RWORDSIZE .EQ. rtypesize ) THEN
995        getrealmpitype = MPI_REAL
996      ELSE IF ( RWORDSIZE .EQ. dtypesize ) THEN
997        getrealmpitype = MPI_DOUBLE_PRECISION
998      ELSE
999        CALL wrf_error_fatal ( 'RWORDSIZE or DWORDSIZE does not match any MPI type' )
1000      ENDIF
1001#else
1002! required dummy initialization for function that is never called
1003      getrealmpitype = 1
1004#endif
1005      RETURN
1006   END FUNCTION getrealmpitype
1007
1008   REAL FUNCTION wrf_dm_max_real ( inval )
1009      IMPLICIT NONE
1010#ifndef STUBMPI
1011      INCLUDE 'mpif.h'
1012      REAL inval, retval
1013      INTEGER ierr
1014      CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_MAX, local_communicator, ierr )
1015      wrf_dm_max_real = retval
1016#else
1017      REAL inval
1018      wrf_dm_max_real = inval
1019#endif
1020   END FUNCTION wrf_dm_max_real
1021
1022   REAL FUNCTION wrf_dm_min_real ( inval )
1023      IMPLICIT NONE
1024#ifndef STUBMPI
1025      INCLUDE 'mpif.h'
1026      REAL inval, retval
1027      INTEGER ierr
1028      CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_MIN, local_communicator, ierr )
1029      wrf_dm_min_real = retval
1030#else
1031      REAL inval
1032      wrf_dm_min_real = inval
1033#endif
1034   END FUNCTION wrf_dm_min_real
1035
1036   SUBROUTINE wrf_dm_min_reals ( inval, retval, n )
1037      IMPLICIT NONE
1038      INTEGER n
1039      REAL inval(*)
1040      REAL retval(*)
1041#ifndef STUBMPI
1042      INCLUDE 'mpif.h'
1043      INTEGER ierr
1044      CALL mpi_allreduce ( inval, retval , n, getrealmpitype(), MPI_MIN, local_communicator, ierr )
1045#else
1046      retval(1:n) = inval(1:n)
1047#endif
1048   END SUBROUTINE wrf_dm_min_reals
1049
1050   REAL FUNCTION wrf_dm_sum_real ( inval )
1051      IMPLICIT NONE
1052#ifndef STUBMPI
1053      INCLUDE 'mpif.h'
1054      REAL inval, retval
1055      INTEGER ierr
1056      CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_SUM, local_communicator, ierr )
1057      wrf_dm_sum_real = retval
1058#else
1059      REAL inval
1060      wrf_dm_sum_real = inval
1061#endif
1062   END FUNCTION wrf_dm_sum_real
1063
1064   SUBROUTINE wrf_dm_sum_reals (inval, retval)
1065      IMPLICIT NONE
1066      REAL, INTENT(IN)  :: inval(:)
1067      REAL, INTENT(OUT) :: retval(:)
1068#ifndef STUBMPI
1069      INCLUDE 'mpif.h'
1070      INTEGER ierr
1071      CALL mpi_allreduce ( inval, retval, SIZE(inval), getrealmpitype(), MPI_SUM, local_communicator, ierr )
1072#else
1073      retval = inval
1074#endif
1075   END SUBROUTINE wrf_dm_sum_reals
1076
1077   INTEGER FUNCTION wrf_dm_sum_integer ( inval )
1078      IMPLICIT NONE
1079#ifndef STUBMPI
1080      INCLUDE 'mpif.h'
1081      INTEGER inval, retval
1082      INTEGER ierr
1083      CALL mpi_allreduce ( inval, retval , 1, MPI_INTEGER, MPI_SUM, local_communicator, ierr )
1084      wrf_dm_sum_integer = retval
1085#else
1086      INTEGER inval
1087      wrf_dm_sum_integer = inval
1088#endif
1089   END FUNCTION wrf_dm_sum_integer
1090
1091   INTEGER FUNCTION wrf_dm_bxor_integer ( inval )
1092      IMPLICIT NONE
1093#ifndef STUBMPI
1094      INCLUDE 'mpif.h'
1095      INTEGER inval, retval
1096      INTEGER ierr
1097      CALL mpi_allreduce ( inval, retval , 1, MPI_INTEGER, MPI_BXOR, local_communicator, ierr )
1098      wrf_dm_bxor_integer = retval
1099#else
1100      INTEGER inval
1101      wrf_dm_bxor_integer = inval
1102#endif
1103   END FUNCTION wrf_dm_bxor_integer
1104
1105   SUBROUTINE wrf_dm_maxval_real ( val, idex, jdex )
1106      IMPLICIT NONE
1107#ifndef STUBMPI
1108      INCLUDE 'mpif.h'
1109      REAL val, val_all( ntasks )
1110      INTEGER idex, jdex, ierr
1111      INTEGER dex(2)
1112      INTEGER dex_all (2,ntasks)
1113      INTEGER i
1114
1115      dex(1) = idex ; dex(2) = jdex
1116      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr )
1117      CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), local_communicator, ierr )
1118      val = val_all(1)
1119      idex = dex_all(1,1) ; jdex = dex_all(2,1)
1120      DO i = 2, ntasks
1121        IF ( val_all(i) .GT. val ) THEN
1122           val = val_all(i)
1123           idex = dex_all(1,i)
1124           jdex = dex_all(2,i)
1125        ENDIF
1126      ENDDO
1127#else
1128      REAL val
1129      INTEGER idex, jdex, ierr
1130#endif
1131   END SUBROUTINE wrf_dm_maxval_real
1132
1133#ifndef PROMOTE_FLOAT
1134   SUBROUTINE wrf_dm_maxval_doubleprecision ( val, idex, jdex )
1135      IMPLICIT NONE
1136# ifndef STUBMPI
1137      INCLUDE 'mpif.h'
1138      DOUBLE PRECISION val, val_all( ntasks )
1139      INTEGER idex, jdex, ierr
1140      INTEGER dex(2)
1141      INTEGER dex_all (2,ntasks)
1142      INTEGER i
1143
1144      dex(1) = idex ; dex(2) = jdex
1145      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr )
1146      CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, local_communicator, ierr )
1147      val = val_all(1)
1148      idex = dex_all(1,1) ; jdex = dex_all(2,1)
1149      DO i = 2, ntasks
1150        IF ( val_all(i) .GT. val ) THEN
1151           val = val_all(i)
1152           idex = dex_all(1,i)
1153           jdex = dex_all(2,i)
1154        ENDIF
1155      ENDDO
1156# else
1157      DOUBLE PRECISION val
1158      INTEGER idex, jdex, ierr
1159# endif
1160   END SUBROUTINE wrf_dm_maxval_doubleprecision
1161#endif
1162
1163   SUBROUTINE wrf_dm_maxval_integer ( val, idex, jdex )
1164      IMPLICIT NONE
1165#ifndef STUBMPI
1166      INCLUDE 'mpif.h'
1167      INTEGER val, val_all( ntasks )
1168      INTEGER idex, jdex, ierr
1169      INTEGER dex(2)
1170      INTEGER dex_all (2,ntasks)
1171      INTEGER i
1172
1173      dex(1) = idex ; dex(2) = jdex
1174      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr )
1175      CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, local_communicator, ierr )
1176      val = val_all(1)
1177      idex = dex_all(1,1) ; jdex = dex_all(2,1)
1178      DO i = 2, ntasks
1179        IF ( val_all(i) .GT. val ) THEN
1180           val = val_all(i)
1181           idex = dex_all(1,i)
1182           jdex = dex_all(2,i)
1183        ENDIF
1184      ENDDO
1185#else
1186      INTEGER val
1187      INTEGER idex, jdex
1188#endif
1189   END SUBROUTINE wrf_dm_maxval_integer
1190
1191!  For HWRF some additional computation is required. This is gopal's doing
1192
1193   SUBROUTINE wrf_dm_minval_real ( val, idex, jdex )
1194      IMPLICIT NONE
1195      REAL val, val_all( ntasks )
1196      INTEGER idex, jdex, ierr
1197      INTEGER dex(2)
1198      INTEGER dex_all (2,ntasks)
1199! <DESCRIPTION>
1200! Collective operation. Each processor calls passing a local value and its index; on return
1201! all processors are passed back the maximum of all values passed and its index.
1202!
1203! </DESCRIPTION>
1204      INTEGER i, comm
1205#ifndef STUBMPI
1206      INCLUDE 'mpif.h'
1207
1208      CALL wrf_get_dm_communicator ( comm )
1209      dex(1) = idex ; dex(2) = jdex
1210      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
1211      CALL mpi_allgather ( val, 1, MPI_REAL, val_all , 1, MPI_REAL, comm, ierr )
1212      val = val_all(1)
1213      idex = dex_all(1,1) ; jdex = dex_all(2,1)
1214      DO i = 2, ntasks
1215        IF ( val_all(i) .LT. val ) THEN
1216           val = val_all(i)
1217           idex = dex_all(1,i)
1218           jdex = dex_all(2,i)
1219        ENDIF
1220      ENDDO
1221#endif
1222   END SUBROUTINE wrf_dm_minval_real
1223
1224#ifndef PROMOTE_FLOAT
1225   SUBROUTINE wrf_dm_minval_doubleprecision ( val, idex, jdex )
1226      IMPLICIT NONE
1227      DOUBLE PRECISION val, val_all( ntasks )
1228      INTEGER idex, jdex, ierr
1229      INTEGER dex(2)
1230      INTEGER dex_all (2,ntasks)
1231! <DESCRIPTION>
1232! Collective operation. Each processor calls passing a local value and its index; on return
1233! all processors are passed back the maximum of all values passed and its index.
1234!
1235! </DESCRIPTION>
1236      INTEGER i, comm
1237#ifndef STUBMPI
1238      INCLUDE 'mpif.h'
1239
1240      CALL wrf_get_dm_communicator ( comm )
1241      dex(1) = idex ; dex(2) = jdex
1242      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
1243      CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
1244      val = val_all(1)
1245      idex = dex_all(1,1) ; jdex = dex_all(2,1)
1246      DO i = 2, ntasks
1247        IF ( val_all(i) .LT. val ) THEN
1248           val = val_all(i)
1249           idex = dex_all(1,i)
1250           jdex = dex_all(2,i)
1251        ENDIF
1252      ENDDO
1253#endif
1254   END SUBROUTINE wrf_dm_minval_doubleprecision
1255#endif
1256
1257   SUBROUTINE wrf_dm_minval_integer ( val, idex, jdex )
1258      IMPLICIT NONE
1259      INTEGER val, val_all( ntasks )
1260      INTEGER idex, jdex, ierr
1261      INTEGER dex(2)
1262      INTEGER dex_all (2,ntasks)
1263! <DESCRIPTION>
1264! Collective operation. Each processor calls passing a local value and its index; on return
1265! all processors are passed back the maximum of all values passed and its index.
1266!
1267! </DESCRIPTION>
1268      INTEGER i, comm
1269#ifndef STUBMPI
1270      INCLUDE 'mpif.h'
1271
1272      CALL wrf_get_dm_communicator ( comm )
1273      dex(1) = idex ; dex(2) = jdex
1274      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
1275      CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
1276      val = val_all(1)
1277      idex = dex_all(1,1) ; jdex = dex_all(2,1)
1278      DO i = 2, ntasks
1279        IF ( val_all(i) .LT. val ) THEN
1280           val = val_all(i)
1281           idex = dex_all(1,i)
1282           jdex = dex_all(2,i)
1283        ENDIF
1284      ENDDO
1285#endif
1286   END SUBROUTINE wrf_dm_minval_integer     ! End of gopal's doing
1287
1288   SUBROUTINE split_communicator
1289#ifndef STUBMPI
1290      IMPLICIT NONE
1291      INCLUDE 'mpif.h'
1292      LOGICAL mpi_inited
1293      INTEGER mpi_comm_here, mpi_comm_local, comdup,  mytask, ntasks, ierr, io_status
1294#  if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT)
1295      INTEGER thread_support_provided, thread_support_requested
1296#endif
1297      INTEGER i, j
1298      INTEGER, ALLOCATABLE :: icolor(:)
1299      INTEGER tasks_per_split
1300      NAMELIST /namelist_split/ tasks_per_split
1301
1302      CALL MPI_INITIALIZED( mpi_inited, ierr )
1303      IF ( .NOT. mpi_inited ) THEN
1304#  if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT)
1305        thread_support_requested = MPI_THREAD_FUNNELED
1306        CALL mpi_init_thread ( thread_support_requested, thread_support_provided, ierr )
1307        IF ( thread_support_provided .lt. thread_support_requested ) THEN
1308           CALL WRF_ERROR_FATAL( "failed to initialize MPI thread support")
1309        ENDIF
1310#  else
1311        CALL mpi_init ( ierr )
1312#  endif
1313        mpi_comm_here = MPI_COMM_WORLD
1314#ifdef HWRF
1315        CALL atm_cmp_start( mpi_comm_here )   ! atmospheric side of HWRF coupler will split MPI_COMM_WORLD and return communicator as argument
1316#endif
1317        CALL wrf_set_dm_communicator( mpi_comm_here )
1318      ENDIF
1319      CALL wrf_get_dm_communicator( mpi_comm_here )
1320      CALL wrf_termio_dup( mpi_comm_here )
1321
1322      CALL MPI_Comm_rank ( mpi_comm_here, mytask, ierr ) ;
1323      CALL mpi_comm_size ( mpi_comm_here, ntasks, ierr ) ;
1324
1325      IF ( mytask .EQ. 0 ) THEN
1326        OPEN ( unit=27, file="namelist.input", form="formatted", status="old" )
1327        tasks_per_split = ntasks
1328        READ ( 27 , NML = namelist_split, IOSTAT=io_status )
1329        CLOSE ( 27 )
1330      ENDIF
1331      CALL mpi_bcast( io_status, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr )
1332      IF ( io_status .NE. 0 ) THEN
1333          RETURN ! just ignore and return
1334      ENDIF
1335      CALL mpi_bcast( tasks_per_split, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr )
1336      IF ( tasks_per_split .GT. ntasks .OR. tasks_per_split .LE. 0 ) RETURN
1337      IF ( mod( ntasks, tasks_per_split ) .NE. 0 ) THEN
1338        CALL wrf_message( 'WARNING: tasks_per_split does not evenly divide ntasks. Some tasks will be wasted.' )
1339      ENDIF
1340
1341      ALLOCATE( icolor(ntasks) )
1342      j = 0
1343      DO WHILE ( j .LT. ntasks / tasks_per_split )
1344        DO i = 1, tasks_per_split
1345          icolor( i + j * tasks_per_split ) = j
1346        ENDDO
1347        j = j + 1
1348      ENDDO
1349
1350      CALL MPI_Comm_dup(mpi_comm_here,comdup,ierr)
1351      CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_local,ierr)
1352      CALL wrf_set_dm_communicator( mpi_comm_local )
1353
1354      DEALLOCATE( icolor )
1355#endif
1356   END SUBROUTINE split_communicator
1357
1358   SUBROUTINE init_module_dm
1359#ifndef STUBMPI
1360      IMPLICIT NONE
1361      INTEGER mpi_comm_local, mpi_comm_here, ierr, mytask, nproc
1362      INCLUDE 'mpif.h'
1363      LOGICAL mpi_inited
1364      CALL mpi_initialized( mpi_inited, ierr )
1365      IF ( .NOT. mpi_inited ) THEN
1366        ! If MPI has not been initialized then initialize it and
1367        ! make comm_world the communicator
1368        ! Otherwise, something else (e.g. split_communicator) has already
1369        ! initialized MPI, so just grab the communicator that
1370        ! should already be stored and use that.
1371        CALL mpi_init ( ierr )
1372        mpi_comm_here = MPI_COMM_WORLD
1373        CALL wrf_set_dm_communicator ( mpi_comm_here )
1374      ENDIF
1375      CALL wrf_get_dm_communicator( mpi_comm_local )
1376      CALL wrf_termio_dup( mpi_comm_local )
1377#endif
1378   END SUBROUTINE init_module_dm
1379
1380! stub
1381   SUBROUTINE wrf_dm_move_nest ( parent, nest, dx, dy )
1382      USE module_domain, ONLY : domain
1383      IMPLICIT NONE
1384      TYPE (domain), INTENT(INOUT) :: parent, nest
1385      INTEGER, INTENT(IN)          :: dx,dy
1386      RETURN
1387   END SUBROUTINE wrf_dm_move_nest
1388
1389!------------------------------------------------------------------------------
1390   SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf,          &
1391                                   mp_local_uobmask,            &
1392                                   mp_local_vobmask,            &
1393                                   mp_local_cobmask, errf )
1394     
1395!------------------------------------------------------------------------------
1396!  PURPOSE: Do MPI allgatherv operation across processors to get the
1397!           errors at each observation point on all processors.
1398!       
1399!------------------------------------------------------------------------------
1400       
1401    INTEGER, INTENT(IN)   :: nsta                ! Observation index.
1402    INTEGER, INTENT(IN)   :: nerrf               ! Number of error fields.
1403    INTEGER, INTENT(IN)   :: niobf               ! Number of observations.
1404    LOGICAL, INTENT(IN)   :: MP_LOCAL_UOBMASK(NIOBF)
1405    LOGICAL, INTENT(IN)   :: MP_LOCAL_VOBMASK(NIOBF)
1406    LOGICAL, INTENT(IN)   :: MP_LOCAL_COBMASK(NIOBF)
1407    REAL, INTENT(INOUT)   :: errf(nerrf, niobf)
1408
1409#ifndef STUBMPI
1410    INCLUDE 'mpif.h'
1411       
1412! Local declarations
1413    integer i, n, nlocal_dot, nlocal_crs
1414    REAL UVT_BUFFER(NIOBF)    ! Buffer for holding U, V, or T
1415    REAL QRK_BUFFER(NIOBF)    ! Buffer for holding Q or RKO
1416    REAL SFP_BUFFER(NIOBF)    ! Buffer for holding Surface pressure
1417    REAL PBL_BUFFER(NIOBF)    ! Buffer for holding (real) KPBL index
1418    INTEGER N_BUFFER(NIOBF)
1419    REAL FULL_BUFFER(NIOBF)
1420    INTEGER IFULL_BUFFER(NIOBF)
1421    INTEGER IDISPLACEMENT(1024)   ! HARD CODED MAX NUMBER OF PROCESSORS
1422    INTEGER ICOUNT(1024)          ! HARD CODED MAX NUMBER OF PROCESSORS
1423
1424    INTEGER :: MPI_COMM_COMP      ! MPI group communicator
1425    INTEGER :: NPROCS             ! Number of processors
1426    INTEGER :: IERR               ! Error code from MPI routines
1427
1428! Get communicator for MPI operations.
1429    CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
1430
1431! Get rank of monitor processor and broadcast to others.
1432    CALL MPI_COMM_SIZE( MPI_COMM_COMP, NPROCS, IERR )
1433
1434! DO THE U FIELD
1435   NLOCAL_DOT = 0
1436   DO N = 1, NSTA
1437     IF ( MP_LOCAL_UOBMASK(N) ) THEN      ! USE U-POINT MASK
1438       NLOCAL_DOT = NLOCAL_DOT + 1
1439       UVT_BUFFER(NLOCAL_DOT) = ERRF(1,N)        ! U WIND COMPONENT
1440       SFP_BUFFER(NLOCAL_DOT) = ERRF(7,N)        ! SURFACE PRESSURE
1441       QRK_BUFFER(NLOCAL_DOT) = ERRF(9,N)        ! RKO
1442       N_BUFFER(NLOCAL_DOT) = N
1443     ENDIF
1444   ENDDO
1445   CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
1446                      ICOUNT,1,MPI_INTEGER,     &
1447                      MPI_COMM_COMP,IERR)
1448   I = 1
1449
1450   IDISPLACEMENT(1) = 0
1451   DO I = 2, NPROCS
1452     IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
1453   ENDDO
1454   CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER,    &
1455                        IFULL_BUFFER, ICOUNT, IDISPLACEMENT,  &
1456                        MPI_INTEGER, MPI_COMM_COMP, IERR)
1457! U
1458   CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL,     &
1459                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
1460                        MPI_REAL, MPI_COMM_COMP, IERR)
1461   DO N = 1, NSTA
1462     ERRF(1,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1463   ENDDO
1464! SURF PRESS AT U-POINTS
1465   CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL,     &
1466                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
1467                        MPI_REAL, MPI_COMM_COMP, IERR)
1468   DO N = 1, NSTA
1469     ERRF(7,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1470   ENDDO
1471! RKO
1472   CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_DOT, MPI_REAL,     &
1473                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
1474                        MPI_REAL, MPI_COMM_COMP, IERR)
1475   DO N = 1, NSTA
1476     ERRF(9,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1477   ENDDO
1478
1479! DO THE V FIELD
1480   NLOCAL_DOT = 0
1481   DO N = 1, NSTA
1482     IF ( MP_LOCAL_VOBMASK(N) ) THEN         ! USE V-POINT MASK
1483       NLOCAL_DOT = NLOCAL_DOT + 1
1484       UVT_BUFFER(NLOCAL_DOT) = ERRF(2,N)    ! V WIND COMPONENT
1485       SFP_BUFFER(NLOCAL_DOT) = ERRF(8,N)    ! SURFACE PRESSURE
1486       N_BUFFER(NLOCAL_DOT) = N
1487     ENDIF
1488   ENDDO
1489   CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
1490                      ICOUNT,1,MPI_INTEGER,     &
1491                      MPI_COMM_COMP,IERR)
1492   I = 1
1493
1494   IDISPLACEMENT(1) = 0
1495   DO I = 2, NPROCS
1496     IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
1497   ENDDO
1498   CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER,    &
1499                        IFULL_BUFFER, ICOUNT, IDISPLACEMENT,  &
1500                        MPI_INTEGER, MPI_COMM_COMP, IERR)
1501! V
1502   CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL,     &
1503                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
1504                        MPI_REAL, MPI_COMM_COMP, IERR)
1505   DO N = 1, NSTA
1506     ERRF(2,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1507   ENDDO
1508! SURF PRESS AT V-POINTS
1509   CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL,     &
1510                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
1511                        MPI_REAL, MPI_COMM_COMP, IERR)
1512   DO N = 1, NSTA
1513     ERRF(8,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1514   ENDDO
1515
1516! DO THE CROSS FIELDS, T AND Q
1517   NLOCAL_CRS = 0
1518   DO N = 1, NSTA
1519     IF ( MP_LOCAL_COBMASK(N) ) THEN       ! USE MASS-POINT MASK
1520       NLOCAL_CRS = NLOCAL_CRS + 1
1521       UVT_BUFFER(NLOCAL_CRS) = ERRF(3,N)     ! TEMPERATURE
1522       QRK_BUFFER(NLOCAL_CRS) = ERRF(4,N)     ! MOISTURE
1523       PBL_BUFFER(NLOCAL_CRS) = ERRF(5,N)     ! KPBL
1524       SFP_BUFFER(NLOCAL_CRS) = ERRF(6,N)     ! SURFACE PRESSURE
1525       N_BUFFER(NLOCAL_CRS) = N
1526     ENDIF
1527   ENDDO
1528   CALL MPI_ALLGATHER(NLOCAL_CRS,1,MPI_INTEGER, &
1529                      ICOUNT,1,MPI_INTEGER,     &
1530                      MPI_COMM_COMP,IERR)
1531   IDISPLACEMENT(1) = 0
1532   DO I = 2, NPROCS
1533     IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
1534   ENDDO
1535   CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_CRS, MPI_INTEGER,    &
1536                        IFULL_BUFFER, ICOUNT, IDISPLACEMENT,  &
1537                        MPI_INTEGER, MPI_COMM_COMP, IERR)
1538! T
1539   CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_CRS, MPI_REAL,     &
1540                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
1541                        MPI_REAL, MPI_COMM_COMP, IERR)
1542
1543   DO N = 1, NSTA
1544     ERRF(3,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1545   ENDDO
1546! Q
1547   CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_CRS, MPI_REAL,     &
1548                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
1549                        MPI_REAL, MPI_COMM_COMP, IERR)
1550   DO N = 1, NSTA
1551     ERRF(4,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1552   ENDDO
1553! KPBL
1554   CALL MPI_ALLGATHERV( PBL_BUFFER, NLOCAL_CRS, MPI_REAL,     &
1555                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
1556                        MPI_REAL, MPI_COMM_COMP, IERR)
1557   DO N = 1, NSTA
1558     ERRF(5,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1559   ENDDO
1560! SURF PRESS AT MASS POINTS
1561   CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_CRS, MPI_REAL,     &
1562                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
1563                        MPI_REAL, MPI_COMM_COMP, IERR)
1564   DO N = 1, NSTA
1565     ERRF(6,IFULL_BUFFER(N)) = FULL_BUFFER(N)
1566   ENDDO
1567#endif
1568   END SUBROUTINE get_full_obs_vector
1569
1570
1571
1572   SUBROUTINE wrf_dm_maxtile_real ( val , tile)
1573      IMPLICIT NONE
1574      REAL val, val_all( ntasks )
1575      INTEGER tile
1576      INTEGER ierr
1577
1578! <DESCRIPTION>
1579! Collective operation. Each processor calls passing a local value and its index; on return
1580! all processors are passed back the maximum of all values passed and its tile number.
1581!
1582! </DESCRIPTION>
1583      INTEGER i, comm
1584#ifndef STUBMPI
1585      INCLUDE 'mpif.h'
1586
1587      CALL wrf_get_dm_communicator ( comm )
1588      CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
1589      val = val_all(1)
1590      tile = 1
1591      DO i = 2, ntasks
1592        IF ( val_all(i) .GT. val ) THEN
1593           tile = i
1594           val = val_all(i)
1595        ENDIF
1596      ENDDO
1597#endif
1598   END SUBROUTINE wrf_dm_maxtile_real
1599
1600
1601   SUBROUTINE wrf_dm_mintile_real ( val , tile)
1602      IMPLICIT NONE
1603      REAL val, val_all( ntasks )
1604      INTEGER tile
1605      INTEGER ierr
1606
1607! <DESCRIPTION>
1608! Collective operation. Each processor calls passing a local value and its index; on return
1609! all processors are passed back the minimum of all values passed and its tile number.
1610!
1611! </DESCRIPTION>
1612      INTEGER i, comm
1613#ifndef STUBMPI
1614      INCLUDE 'mpif.h'
1615
1616      CALL wrf_get_dm_communicator ( comm )
1617      CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
1618      val = val_all(1)
1619      tile = 1
1620      DO i = 2, ntasks
1621        IF ( val_all(i) .LT. val ) THEN
1622           tile = i
1623           val = val_all(i)
1624        ENDIF
1625      ENDDO
1626#endif
1627   END SUBROUTINE wrf_dm_mintile_real
1628
1629
1630   SUBROUTINE wrf_dm_mintile_double ( val , tile)
1631      IMPLICIT NONE
1632      DOUBLE PRECISION val, val_all( ntasks )
1633      INTEGER tile
1634      INTEGER ierr
1635
1636! <DESCRIPTION>
1637! Collective operation. Each processor calls passing a local value and its index; on return
1638! all processors are passed back the minimum of all values passed and its tile number.
1639!
1640! </DESCRIPTION>
1641      INTEGER i, comm
1642#ifndef STUBMPI
1643      INCLUDE 'mpif.h'
1644
1645      CALL wrf_get_dm_communicator ( comm )
1646      CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
1647      val = val_all(1)
1648      tile = 1
1649      DO i = 2, ntasks
1650        IF ( val_all(i) .LT. val ) THEN
1651           tile = i
1652           val = val_all(i)
1653        ENDIF
1654      ENDDO
1655#endif
1656   END SUBROUTINE wrf_dm_mintile_double
1657
1658
1659   SUBROUTINE wrf_dm_tile_val_int ( val , tile)
1660      IMPLICIT NONE
1661      INTEGER val, val_all( ntasks )
1662      INTEGER tile
1663      INTEGER ierr
1664
1665! <DESCRIPTION>
1666! Collective operation. Get value from input tile.
1667!
1668! </DESCRIPTION>
1669      INTEGER i, comm
1670#ifndef STUBMPI
1671      INCLUDE 'mpif.h'
1672
1673      CALL wrf_get_dm_communicator ( comm )
1674      CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
1675      val = val_all(tile)
1676#endif
1677   END SUBROUTINE wrf_dm_tile_val_int
1678
1679   SUBROUTINE wrf_get_hostname  ( str )
1680      CHARACTER*(*) str
1681      CHARACTER tmp(512)
1682      INTEGER i , n, cs
1683      CALL rsl_lite_get_hostname( tmp, 512, n, cs )
1684      DO i = 1, n
1685        str(i:i) = tmp(i)
1686      ENDDO
1687      RETURN
1688   END SUBROUTINE wrf_get_hostname
1689
1690   SUBROUTINE wrf_get_hostid  ( hostid )
1691      INTEGER hostid
1692      CHARACTER tmp(512)
1693      INTEGER i, sz, n, cs
1694      CALL rsl_lite_get_hostname( tmp, 512, n, cs )
1695      hostid = cs
1696      RETURN
1697   END SUBROUTINE wrf_get_hostid
1698
1699END MODULE module_dm
1700
1701!=========================================================================
1702! wrf_dm_patch_domain has to be outside the module because it is called
1703! by a routine in module_domain but depends on module domain
1704
1705SUBROUTINE wrf_dm_patch_domain ( id  , domdesc , parent_id , parent_domdesc , &
1706                          sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
1707                          sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
1708                          sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
1709                                      sp1x , ep1x , sm1x , em1x , &
1710                                      sp2x , ep2x , sm2x , em2x , &
1711                                      sp3x , ep3x , sm3x , em3x , &
1712                                      sp1y , ep1y , sm1y , em1y , &
1713                                      sp2y , ep2y , sm2y , em2y , &
1714                                      sp3y , ep3y , sm3y , em3y , &
1715                          bdx , bdy )
1716   USE module_domain, ONLY : domain, head_grid, find_grid_by_id
1717   USE module_dm, ONLY : patch_domain_rsl_lite
1718   IMPLICIT NONE
1719
1720   INTEGER, INTENT(IN)   :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
1721   INTEGER, INTENT(OUT)  :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , &
1722                            sm1 , em1 , sm2 , em2 , sm3 , em3
1723   INTEGER               :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &
1724                            sm1x , em1x , sm2x , em2x , sm3x , em3x
1725   INTEGER               :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &
1726                            sm1y , em1y , sm2y , em2y , sm3y , em3y
1727   INTEGER, INTENT(INOUT):: id  , domdesc , parent_id , parent_domdesc
1728
1729   TYPE(domain), POINTER :: parent
1730   TYPE(domain), POINTER :: grid_ptr
1731
1732   ! this is necessary because we cannot pass parent directly into
1733   ! wrf_dm_patch_domain because creating the correct interface definitions
1734   ! would generate a circular USE reference between module_domain and module_dm
1735   ! see comment this date in module_domain for more information. JM 20020416
1736
1737   NULLIFY( parent )
1738   grid_ptr => head_grid
1739   CALL find_grid_by_id( parent_id , grid_ptr , parent )
1740
1741   CALL patch_domain_rsl_lite ( id  , parent, parent_id , &
1742                           sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
1743                           sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
1744                           sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
1745                                      sp1x , ep1x , sm1x , em1x , &
1746                                      sp2x , ep2x , sm2x , em2x , &
1747                                      sp3x , ep3x , sm3x , em3x , &
1748                                      sp1y , ep1y , sm1y , em1y , &
1749                                      sp2y , ep2y , sm2y , em2y , &
1750                                      sp3y , ep3y , sm3y , em3y , &
1751                           bdx , bdy )
1752
1753   RETURN
1754END SUBROUTINE wrf_dm_patch_domain
1755
1756SUBROUTINE wrf_termio_dup( comm )
1757  IMPLICIT NONE
1758  INTEGER, INTENT(IN) :: comm
1759  INTEGER mytask, ntasks
1760#ifndef STUBMPI
1761  INTEGER ierr
1762  INCLUDE 'mpif.h'
1763  CALL mpi_comm_size(comm, ntasks, ierr )
1764  CALL mpi_comm_rank(comm, mytask, ierr )
1765  write(0,*)'starting wrf task ',mytask,' of ',ntasks
1766  CALL rsl_error_dup1( mytask )
1767#else
1768  mytask = 0
1769  ntasks = 1
1770#endif
1771END SUBROUTINE wrf_termio_dup
1772
1773SUBROUTINE wrf_get_myproc( myproc )
1774  USE module_dm , ONLY : mytask
1775  IMPLICIT NONE
1776  INTEGER myproc
1777  myproc = mytask
1778  RETURN
1779END SUBROUTINE wrf_get_myproc
1780
1781SUBROUTINE wrf_get_nproc( nproc )
1782  USE module_dm , ONLY : ntasks
1783  IMPLICIT NONE
1784  INTEGER nproc
1785  nproc = ntasks
1786  RETURN
1787END SUBROUTINE wrf_get_nproc
1788
1789SUBROUTINE wrf_get_nprocx( nprocx )
1790  USE module_dm , ONLY : ntasks_x
1791  IMPLICIT NONE
1792  INTEGER nprocx
1793  nprocx = ntasks_x
1794  RETURN
1795END SUBROUTINE wrf_get_nprocx
1796
1797SUBROUTINE wrf_get_nprocy( nprocy )
1798  USE module_dm , ONLY : ntasks_y
1799  IMPLICIT NONE
1800  INTEGER nprocy
1801  nprocy = ntasks_y
1802  RETURN
1803END SUBROUTINE wrf_get_nprocy
1804
1805SUBROUTINE wrf_dm_bcast_bytes ( buf , size )
1806   USE module_dm , ONLY : local_communicator
1807   IMPLICIT NONE
1808#ifndef STUBMPI
1809   INCLUDE 'mpif.h'
1810#endif
1811   INTEGER size
1812#ifndef NEC
1813   INTEGER*1 BUF(size)
1814#else
1815   CHARACTER*1 BUF(size)
1816#endif
1817#ifndef STUBMPI
1818   CALL BYTE_BCAST ( buf , size, local_communicator )
1819#endif
1820   RETURN
1821END SUBROUTINE wrf_dm_bcast_bytes
1822
1823SUBROUTINE wrf_dm_bcast_string( BUF, N1 )
1824   IMPLICIT NONE
1825   INTEGER n1
1826! <DESCRIPTION>
1827! Collective operation. Given a string and a size in characters on task zero, broadcast and return that buffer on all tasks.
1828!
1829! </DESCRIPTION>
1830   CHARACTER*(*) buf
1831#ifndef STUBMPI
1832   INTEGER ibuf(256),i,n
1833   CHARACTER*256 tstr
1834   n = n1
1835   ! Root task is required to have the correct value of N1, other tasks
1836   ! might not have the correct value. 
1837   CALL wrf_dm_bcast_integer( n , 1 )
1838   IF (n .GT. 256) n = 256
1839   IF (n .GT. 0 ) then
1840     DO i = 1, n
1841       ibuf(I) = ichar(buf(I:I))
1842     ENDDO
1843     CALL wrf_dm_bcast_integer( ibuf, n )
1844     buf = ''
1845     DO i = 1, n
1846       buf(i:i) = char(ibuf(i))
1847     ENDDO
1848   ENDIF
1849#endif
1850   RETURN
1851END SUBROUTINE wrf_dm_bcast_string
1852
1853SUBROUTINE wrf_dm_bcast_integer( BUF, N1 )
1854   IMPLICIT NONE
1855   INTEGER n1
1856   INTEGER  buf(*)
1857   CALL wrf_dm_bcast_bytes ( BUF , N1 * IWORDSIZE )
1858   RETURN
1859END SUBROUTINE wrf_dm_bcast_integer
1860
1861SUBROUTINE wrf_dm_bcast_double( BUF, N1 )
1862   IMPLICIT NONE
1863   INTEGER n1
1864! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
1865! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
1866! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
1867! since we were not indexing the globbuf and Field arrays it does not matter
1868   REAL  buf(*)
1869   CALL wrf_dm_bcast_bytes ( BUF , N1 * DWORDSIZE )
1870   RETURN
1871END SUBROUTINE wrf_dm_bcast_double
1872
1873SUBROUTINE wrf_dm_bcast_real( BUF, N1 )
1874   IMPLICIT NONE
1875   INTEGER n1
1876   REAL  buf(*)
1877   CALL wrf_dm_bcast_bytes ( BUF , N1 * RWORDSIZE )
1878   RETURN
1879END SUBROUTINE wrf_dm_bcast_real
1880
1881SUBROUTINE wrf_dm_bcast_logical( BUF, N1 )
1882   IMPLICIT NONE
1883   INTEGER n1
1884   LOGICAL  buf(*)
1885   CALL wrf_dm_bcast_bytes ( BUF , N1 * LWORDSIZE )
1886   RETURN
1887END SUBROUTINE wrf_dm_bcast_logical
1888
1889SUBROUTINE write_68( grid, v , s , &
1890                   ids, ide, jds, jde, kds, kde, &
1891                   ims, ime, jms, jme, kms, kme, &
1892                   its, ite, jts, jte, kts, kte )
1893  USE module_domain, ONLY : domain
1894  IMPLICIT NONE
1895  TYPE(domain) , INTENT (INOUT) :: grid
1896  CHARACTER *(*) s
1897  INTEGER ids, ide, jds, jde, kds, kde, &
1898          ims, ime, jms, jme, kms, kme, &
1899          its, ite, jts, jte, kts, kte
1900  REAL, DIMENSION( ims:ime , kms:kme, jms:jme ) :: v
1901
1902  INTEGER i,j,k,ierr
1903
1904  logical, external :: wrf_dm_on_monitor
1905  real globbuf( ids:ide, kds:kde, jds:jde )
1906  character*3 ord, stag
1907
1908  if ( kds == kde ) then
1909    ord = 'xy'
1910    stag = 'xy'
1911  CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
1912                     ids, ide, jds, jde, kds, kde, &
1913                     ims, ime, jms, jme, kms, kme, &
1914                     its, ite, jts, jte, kts, kte )
1915  else
1916
1917    stag = 'xyz'
1918    ord = 'xzy'
1919  CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
1920                     ids, ide, kds, kde, jds, jde, &
1921                     ims, ime, kms, kme, jms, jme, &
1922                     its, ite, kts, kte, jts, jte )
1923  endif
1924
1925
1926  if ( wrf_dm_on_monitor() ) THEN
1927    WRITE(68,*) ide-ids+1, jde-jds+1 , s
1928    DO j = jds, jde
1929    DO i = ids, ide
1930       WRITE(68,*) globbuf(i,1,j)
1931    ENDDO
1932    ENDDO
1933  endif
1934
1935  RETURN
1936END
1937
1938   SUBROUTINE wrf_abort
1939      IMPLICIT NONE
1940#ifndef STUBMPI
1941      INCLUDE 'mpif.h'
1942      INTEGER ierr
1943      CALL mpi_abort(MPI_COMM_WORLD,1,ierr)
1944#else
1945      STOP
1946#endif
1947   END SUBROUTINE wrf_abort
1948
1949   SUBROUTINE wrf_dm_shutdown
1950      IMPLICIT NONE
1951#ifndef STUBMPI
1952      INTEGER ierr
1953      CALL MPI_FINALIZE( ierr )
1954#endif
1955      RETURN
1956   END SUBROUTINE wrf_dm_shutdown
1957
1958   LOGICAL FUNCTION wrf_dm_on_monitor()
1959      IMPLICIT NONE
1960#ifndef STUBMPI
1961      INCLUDE 'mpif.h'
1962      INTEGER tsk, ierr, mpi_comm_local
1963      CALL wrf_get_dm_communicator( mpi_comm_local )
1964      CALL mpi_comm_rank ( mpi_comm_local, tsk , ierr )
1965      wrf_dm_on_monitor = tsk .EQ. 0
1966#else
1967      wrf_dm_on_monitor = .TRUE.
1968#endif
1969      RETURN
1970   END FUNCTION wrf_dm_on_monitor
1971
1972   SUBROUTINE rsl_comm_iter_init(shw,ps,pe)
1973      INTEGER shw, ps, pe
1974      INTEGER iter, plus_send_start, plus_recv_start, &
1975                    minus_send_start, minus_recv_start
1976      COMMON /rcii/ iter, plus_send_start, plus_recv_start, &
1977                          minus_send_start, minus_recv_start
1978      iter = 0
1979      minus_send_start = ps
1980      minus_recv_start = ps-1
1981      plus_send_start = pe
1982      plus_recv_start = pe+1
1983   END SUBROUTINE rsl_comm_iter_init
1984
1985   LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate,                     &
1986                                    shw ,  xy , ds, de_in, ps, pe, nds,nde, &
1987                                    sendbeg_m, sendw_m, sendbeg_p, sendw_p,   &
1988                                    recvbeg_m, recvw_m, recvbeg_p, recvw_p    )
1989      USE module_dm, ONLY : ntasks_x, ntasks_y, mytask_x, mytask_y
1990      IMPLICIT NONE
1991      INTEGER, INTENT(IN)  :: id,shw,xy,ds,de_in,ps,pe,nds,nde
1992      LOGICAL, INTENT(IN)  :: is_intermediate  ! treated differently, coarse but with same decomp as nest
1993      INTEGER, INTENT(OUT) :: sendbeg_m, sendw_m, sendbeg_p, sendw_p
1994      INTEGER, INTENT(OUT) :: recvbeg_m, recvw_m, recvbeg_p, recvw_p
1995      INTEGER k, kn, ni, nj, de, Px, Py, nt, me, lb, ub, ierr
1996      LOGICAL went
1997      INTEGER iter, plus_send_start, plus_recv_start, &
1998                    minus_send_start, minus_recv_start
1999      INTEGER parent_grid_ratio, parent_start
2000      COMMON /rcii/ iter, plus_send_start, plus_recv_start, &
2001                          minus_send_start, minus_recv_start
2002
2003#if (NMM_CORE == 1 )
2004! In case of NMM CORE, the domain only ever runs from ids..ide-1 and jds..jde-1 so
2005! adjust decomposition to reflect.  20081206 JM
2006      de = de_in - 1
2007#else
2008      de = de_in
2009#endif
2010
2011      IF ( xy .EQ. 1 ) THEN  ! X/I axis
2012        nt = ntasks_x
2013        me = mytask_x
2014        IF ( is_intermediate ) THEN
2015           CALL nl_get_i_parent_start(id,parent_start)
2016           CALL nl_get_parent_grid_ratio(id,parent_grid_ratio)
2017        ENDIF
2018      ELSE
2019        nt = ntasks_y
2020        me = mytask_y
2021        IF ( is_intermediate ) THEN
2022           CALL nl_get_j_parent_start(id,parent_start)
2023           CALL nl_get_parent_grid_ratio(id,parent_grid_ratio)
2024        ENDIF
2025      ENDIF
2026      iter = iter + 1
2027
2028#if (DA_CORE == 0)
2029      went = .FALSE.
2030      ! send to minus
2031      sendw_m = 0
2032      sendbeg_m = 1
2033      IF ( me .GT. 0 ) THEN
2034        lb = minus_send_start
2035        sendbeg_m = lb-ps+1
2036        DO k = lb,ps+shw-1
2037          went = .TRUE.
2038          IF ( is_intermediate ) THEN
2039            kn =  ( k - parent_start ) * parent_grid_ratio + 1 + 1 ;
2040            CALL task_for_point (kn,1,nds,nde,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
2041          ELSE
2042            CALL task_for_point (k,1,ds,de,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
2043          ENDIF
2044          IF ( Px .NE. me+(iter-1) ) THEN
2045            exit
2046          ENDIF
2047          minus_send_start = minus_send_start+1
2048          sendw_m = sendw_m + 1
2049        ENDDO
2050      ENDIF
2051      ! recv from minus
2052      recvw_m = 0
2053      recvbeg_m = 1
2054      IF ( me .GT. 0 ) THEN
2055        ub = minus_recv_start
2056        recvbeg_m = ps - ub
2057        DO k = minus_recv_start,ps-shw,-1
2058          went = .TRUE.
2059          IF ( is_intermediate ) THEN
2060            kn =  ( k - parent_start ) * parent_grid_ratio + 1 + 1 ;
2061            CALL task_for_point (kn,1,nds,nde,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
2062          ELSE
2063            CALL task_for_point (k,1,ds,de,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
2064          ENDIF
2065          IF ( Px .NE. me-iter ) THEN
2066            exit
2067          ENDIF
2068          minus_recv_start = minus_recv_start-1
2069          recvw_m = recvw_m + 1
2070        ENDDO
2071      ENDIF
2072
2073      ! send to plus
2074      sendw_p = 0
2075      sendbeg_p = 1
2076      IF ( me .LT. nt-1 ) THEN
2077        ub = plus_send_start
2078        sendbeg_p = pe - ub + 1
2079        DO k = ub,pe-shw+1,-1
2080          went = .TRUE.
2081          IF ( is_intermediate ) THEN
2082            kn =  ( k - parent_start ) * parent_grid_ratio + 1 + 1 ;
2083            CALL task_for_point (kn,1,nds,nde,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
2084          ELSE
2085            CALL task_for_point (k,1,ds,de,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
2086          ENDIF
2087          IF ( Px .NE. me-(iter-1) ) THEN
2088            exit
2089          ENDIF
2090          plus_send_start = plus_send_start - 1
2091          sendw_p = sendw_p + 1
2092        ENDDO
2093      ENDIF
2094      ! recv from plus
2095      recvw_p = 0
2096      recvbeg_p = 1
2097      IF ( me .LT. nt-1 ) THEN
2098        lb = plus_recv_start
2099        recvbeg_p = lb - pe
2100        DO k = lb,pe+shw
2101          went = .TRUE.
2102          IF ( is_intermediate ) THEN
2103            kn =  ( k - parent_start ) * parent_grid_ratio + 1 + 1 ;
2104            CALL task_for_point (kn,1,nds,nde,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
2105          ELSE
2106            CALL task_for_point (k,1,ds,de,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
2107          ENDIF
2108          IF ( Px .NE. me+iter ) THEN
2109            exit
2110          ENDIF
2111          plus_recv_start = plus_recv_start + 1
2112          recvw_p = recvw_p + 1
2113        ENDDO
2114      ENDIF
2115#else
2116      if ( iter .eq. 1 ) then
2117        went = .true.
2118      else
2119        went = .false.
2120      endif
2121      sendw_m = 0 ; sendw_p = 0 ; recvw_m = 0 ; recvw_p = 0
2122      sendbeg_m = 1 ; if ( me .GT. 0 ) sendw_m = shw ;
2123      sendbeg_p = 1 ; if ( me .LT. nt-1 ) sendw_p = shw
2124      recvbeg_m = 1 ; if ( me .GT. 0 ) recvw_m = shw ;
2125      recvbeg_p = 1 ; if ( me .LT. nt-1 ) recvw_p = shw ;
2126
2127      ! write(0,*)'shw  ', shw , ' xy ',xy
2128      ! write(0,*)' ds, de, ps, pe, nds,nde ',ds, de, ps, pe, nds,nde
2129      ! write(0,*)'sendbeg_m, sendw_m, sendbeg_p, sendw_p, recvbeg_m, recvw_m, recvbeg_p, recvw_p '
2130      ! write(0,*)sendbeg_m, sendw_m, sendbeg_p, sendw_p, recvbeg_m, recvw_m, recvbeg_p, recvw_p
2131#endif
2132      !if ( went ) then
2133      !  write(0,*)'shw  ', shw , ' xy ',xy
2134      !  write(0,*)' ds, de, ps, pe, nds,nde ',ds, de, ps, pe, nds,nde
2135      !  write(0,*)'sendbeg_m, sendw_m, sendbeg_p, sendw_p, recvbeg_m, recvw_m, recvbeg_p, recvw_p '
2136      !  write(0,*)sendbeg_m, sendw_m, sendbeg_p, sendw_p, recvbeg_m, recvw_m, recvbeg_p, recvw_p
2137      !endif
2138      rsl_comm_iter = went
2139   END FUNCTION rsl_comm_iter
2140
2141   INTEGER FUNCTION wrf_dm_monitor_rank()
2142      IMPLICIT NONE
2143      wrf_dm_monitor_rank = 0
2144      RETURN
2145   END FUNCTION wrf_dm_monitor_rank
2146
2147   SUBROUTINE wrf_get_dm_communicator ( communicator )
2148      USE module_dm , ONLY : local_communicator
2149      IMPLICIT NONE
2150      INTEGER , INTENT(OUT) :: communicator
2151      communicator = local_communicator
2152      RETURN
2153   END SUBROUTINE wrf_get_dm_communicator
2154
2155   SUBROUTINE wrf_get_dm_communicator_x ( communicator )
2156      USE module_dm , ONLY : local_communicator_x
2157      IMPLICIT NONE
2158      INTEGER , INTENT(OUT) :: communicator
2159      communicator = local_communicator_x
2160      RETURN
2161   END SUBROUTINE wrf_get_dm_communicator_x
2162
2163   SUBROUTINE wrf_get_dm_communicator_y ( communicator )
2164      USE module_dm , ONLY : local_communicator_y
2165      IMPLICIT NONE
2166      INTEGER , INTENT(OUT) :: communicator
2167      communicator = local_communicator_y
2168      RETURN
2169   END SUBROUTINE wrf_get_dm_communicator_y
2170
2171   SUBROUTINE wrf_get_dm_iocommunicator ( iocommunicator )
2172      USE module_dm , ONLY : local_iocommunicator
2173      IMPLICIT NONE
2174      INTEGER , INTENT(OUT) :: iocommunicator
2175      iocommunicator = local_iocommunicator
2176      RETURN
2177   END SUBROUTINE wrf_get_dm_iocommunicator
2178
2179   SUBROUTINE wrf_set_dm_communicator ( communicator )
2180      USE module_dm , ONLY : local_communicator
2181      IMPLICIT NONE
2182      INTEGER , INTENT(IN) :: communicator
2183      local_communicator = communicator
2184      RETURN
2185   END SUBROUTINE wrf_set_dm_communicator
2186
2187   SUBROUTINE wrf_set_dm_iocommunicator ( iocommunicator )
2188      USE module_dm , ONLY : local_iocommunicator
2189      IMPLICIT NONE
2190      INTEGER , INTENT(IN) :: iocommunicator
2191      local_iocommunicator = iocommunicator
2192      RETURN
2193   END SUBROUTINE wrf_set_dm_iocommunicator
2194
2195   SUBROUTINE wrf_get_dm_ntasks_x ( retval )
2196      USE module_dm , ONLY : ntasks_x
2197      IMPLICIT NONE
2198      INTEGER , INTENT(OUT) :: retval
2199      retval = ntasks_x
2200      RETURN
2201   END SUBROUTINE wrf_get_dm_ntasks_x
2202
2203   SUBROUTINE wrf_get_dm_ntasks_y ( retval )
2204      USE module_dm , ONLY : ntasks_y
2205      IMPLICIT NONE
2206      INTEGER , INTENT(OUT) :: retval
2207      retval = ntasks_y
2208      RETURN
2209   END SUBROUTINE wrf_get_dm_ntasks_y
2210
2211
2212!!!!!!!!!!!!!!!!!!!!!!! PATCH TO GLOBAL !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2213
2214   SUBROUTINE wrf_patch_to_global_real (buf,globbuf,domdesc,stagger,ordering,&
2215                                       DS1,DE1,DS2,DE2,DS3,DE3,&
2216                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2217                                       PS1,PE1,PS2,PE2,PS3,PE3 )
2218       IMPLICIT NONE
2219       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
2220                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2221                                       PS1,PE1,PS2,PE2,PS3,PE3
2222       CHARACTER *(*) stagger,ordering
2223       INTEGER fid,domdesc
2224       REAL globbuf(*)
2225       REAL buf(*)
2226
2227       CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,RWORDSIZE,&
2228                                         DS1,DE1,DS2,DE2,DS3,DE3,&
2229                                         MS1,ME1,MS2,ME2,MS3,ME3,&
2230                                         PS1,PE1,PS2,PE2,PS3,PE3 )
2231
2232       RETURN
2233   END SUBROUTINE wrf_patch_to_global_real
2234
2235   SUBROUTINE wrf_patch_to_global_double (buf,globbuf,domdesc,stagger,ordering,&
2236                                       DS1,DE1,DS2,DE2,DS3,DE3,&
2237                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2238                                       PS1,PE1,PS2,PE2,PS3,PE3 )
2239       IMPLICIT NONE
2240       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
2241                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2242                                       PS1,PE1,PS2,PE2,PS3,PE3
2243       CHARACTER *(*) stagger,ordering
2244       INTEGER fid,domdesc
2245! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
2246! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
2247! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
2248! since we were not indexing the globbuf and Field arrays it does not matter
2249       REAL globbuf(*)
2250       REAL buf(*)
2251
2252       CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,DWORDSIZE,&
2253                                         DS1,DE1,DS2,DE2,DS3,DE3,&
2254                                         MS1,ME1,MS2,ME2,MS3,ME3,&
2255                                         PS1,PE1,PS2,PE2,PS3,PE3 )
2256
2257       RETURN
2258   END SUBROUTINE wrf_patch_to_global_double
2259
2260
2261   SUBROUTINE wrf_patch_to_global_integer (buf,globbuf,domdesc,stagger,ordering,&
2262                                       DS1,DE1,DS2,DE2,DS3,DE3,&
2263                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2264                                       PS1,PE1,PS2,PE2,PS3,PE3 )
2265       IMPLICIT NONE
2266       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
2267                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2268                                       PS1,PE1,PS2,PE2,PS3,PE3
2269       CHARACTER *(*) stagger,ordering
2270       INTEGER fid,domdesc
2271       INTEGER globbuf(*)
2272       INTEGER buf(*)
2273
2274       CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,IWORDSIZE,&
2275                                         DS1,DE1,DS2,DE2,DS3,DE3,&
2276                                         MS1,ME1,MS2,ME2,MS3,ME3,&
2277                                         PS1,PE1,PS2,PE2,PS3,PE3 )
2278
2279       RETURN
2280   END SUBROUTINE wrf_patch_to_global_integer
2281
2282
2283   SUBROUTINE wrf_patch_to_global_logical (buf,globbuf,domdesc,stagger,ordering,&
2284                                       DS1,DE1,DS2,DE2,DS3,DE3,&
2285                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2286                                       PS1,PE1,PS2,PE2,PS3,PE3 )
2287       IMPLICIT NONE
2288       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
2289                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2290                                       PS1,PE1,PS2,PE2,PS3,PE3
2291       CHARACTER *(*) stagger,ordering
2292       INTEGER fid,domdesc
2293       LOGICAL globbuf(*)
2294       LOGICAL buf(*)
2295
2296       CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,LWORDSIZE,&
2297                                         DS1,DE1,DS2,DE2,DS3,DE3,&
2298                                         MS1,ME1,MS2,ME2,MS3,ME3,&
2299                                         PS1,PE1,PS2,PE2,PS3,PE3 )
2300
2301       RETURN
2302   END SUBROUTINE wrf_patch_to_global_logical
2303
2304#ifdef DEREF_KLUDGE
2305#  define FRSTELEM (1)
2306#else
2307#  define FRSTELEM
2308#endif
2309
2310   SUBROUTINE wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,typesize,&
2311                                       DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
2312                                       MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
2313                                       PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
2314       USE module_driver_constants
2315       USE module_timing
2316       USE module_wrf_error, ONLY : wrf_at_debug_level
2317       USE module_dm, ONLY : local_communicator, ntasks
2318
2319       IMPLICIT NONE
2320       INTEGER                         DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
2321                                       MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
2322                                       PS1a,PE1a,PS2a,PE2a,PS3a,PE3A
2323       CHARACTER *(*) stagger,ordering
2324       INTEGER domdesc,typesize,ierr
2325       REAL globbuf(*)
2326       REAL buf(*)
2327#ifndef STUBMPI
2328       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
2329                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2330                                       PS1,PE1,PS2,PE2,PS3,PE3
2331       INTEGER                         ids,ide,jds,jde,kds,kde,&
2332                                       ims,ime,jms,jme,kms,kme,&
2333                                       ips,ipe,jps,jpe,kps,kpe
2334       LOGICAL, EXTERNAL :: wrf_dm_on_monitor, has_char
2335
2336       INTEGER i, j, k,  ndim
2337       INTEGER  Patch(3,2), Gpatch(3,2,ntasks)
2338    ! allocated further down, after the D indices are potentially recalculated for staggering
2339       REAL, ALLOCATABLE :: tmpbuf( : )
2340       REAL locbuf( (PE1a-PS1a+1)*(PE2a-PS2a+1)*(PE3a-PS3a+1)/RWORDSIZE*typesize+32 )
2341
2342       DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
2343       MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
2344       PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
2345
2346       SELECT CASE ( TRIM(ordering) )
2347         CASE ( 'xy', 'yx' )
2348           ndim = 2
2349         CASE DEFAULT
2350           ndim = 3   ! where appropriate
2351       END SELECT
2352
2353       SELECT CASE ( TRIM(ordering) )
2354         CASE ( 'xyz','xy' )
2355            ! the non-staggered variables come in at one-less than
2356            ! domain dimensions, but code wants full domain spec, so
2357            ! adjust if not staggered
2358           IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
2359           IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
2360           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
2361         CASE ( 'yxz','yx' )
2362           IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
2363           IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
2364           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
2365         CASE ( 'zxy' )
2366           IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
2367           IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
2368           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
2369         CASE ( 'xzy' )
2370           IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
2371           IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
2372           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
2373         CASE DEFAULT
2374       END SELECT
2375
2376     ! moved to here to be after the potential recalculations of D dims
2377       IF ( wrf_dm_on_monitor() ) THEN
2378         ALLOCATE ( tmpbuf ( (DE1-DS1+1)*(DE2-DS2+1)*(DE3-DS3+1)/RWORDSIZE*typesize+32 ), STAT=ierr )
2379       ELSE
2380         ALLOCATE ( tmpbuf ( 1 ), STAT=ierr )
2381       ENDIF
2382       IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating tmpbuf in wrf_patch_to_global_generic')
2383 
2384       Patch(1,1) = ps1 ; Patch(1,2) = pe1    ! use patch dims
2385       Patch(2,1) = ps2 ; Patch(2,2) = pe2
2386       Patch(3,1) = ps3 ; Patch(3,2) = pe3
2387
2388       IF      ( typesize .EQ. RWORDSIZE ) THEN
2389         CALL just_patch_r ( buf , locbuf , size(locbuf), &
2390                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
2391                                   MS1, ME1, MS2, ME2, MS3, ME3   )
2392       ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
2393         CALL just_patch_i ( buf , locbuf , size(locbuf), &
2394                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
2395                                   MS1, ME1, MS2, ME2, MS3, ME3   )
2396       ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
2397         CALL just_patch_d ( buf , locbuf , size(locbuf), &
2398                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
2399                                   MS1, ME1, MS2, ME2, MS3, ME3   )
2400       ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
2401         CALL just_patch_l ( buf , locbuf , size(locbuf), &
2402                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
2403                                   MS1, ME1, MS2, ME2, MS3, ME3   )
2404       ENDIF
2405
2406! defined in external/io_quilt
2407       CALL collect_on_comm0 (  local_communicator , IWORDSIZE ,  &
2408                                Patch , 6 ,                       &
2409                                GPatch , 6*ntasks                 )
2410
2411       CALL collect_on_comm0 (  local_communicator , typesize ,  &
2412                                locbuf , (pe1-ps1+1)*(pe2-ps2+1)*(pe3-ps3+1),   &
2413                                tmpbuf FRSTELEM , (de1-ds1+1)*(de2-ds2+1)*(de3-ds3+1) )
2414
2415       ndim = len(TRIM(ordering))
2416
2417       IF ( wrf_at_debug_level(500) ) THEN
2418         CALL start_timing
2419       ENDIF
2420
2421       IF ( ndim .GE. 2 .AND. wrf_dm_on_monitor() ) THEN
2422
2423         IF      ( typesize .EQ. RWORDSIZE ) THEN
2424           CALL patch_2_outbuf_r ( tmpbuf FRSTELEM , globbuf ,             &
2425                                   DS1, DE1, DS2, DE2, DS3, DE3 , &
2426                                   GPATCH                         )
2427         ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
2428           CALL patch_2_outbuf_i ( tmpbuf FRSTELEM , globbuf ,             &
2429                                   DS1, DE1, DS2, DE2, DS3, DE3 , &
2430                                   GPATCH                         )
2431         ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
2432           CALL patch_2_outbuf_d ( tmpbuf FRSTELEM , globbuf ,             &
2433                                   DS1, DE1, DS2, DE2, DS3, DE3 , &
2434                                   GPATCH                         )
2435         ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
2436           CALL patch_2_outbuf_l ( tmpbuf FRSTELEM , globbuf ,             &
2437                                   DS1, DE1, DS2, DE2, DS3, DE3 , &
2438                                   GPATCH                         )
2439         ENDIF
2440
2441       ENDIF
2442
2443       IF ( wrf_at_debug_level(500) ) THEN
2444         CALL end_timing('wrf_patch_to_global_generic')
2445       ENDIF
2446       DEALLOCATE( tmpbuf )
2447#endif
2448       RETURN
2449    END SUBROUTINE wrf_patch_to_global_generic
2450
2451  SUBROUTINE just_patch_i ( inbuf , outbuf, noutbuf,     &
2452                               PS1,PE1,PS2,PE2,PS3,PE3,  &
2453                               MS1,ME1,MS2,ME2,MS3,ME3   )
2454    IMPLICIT NONE
2455    INTEGER                         , INTENT(IN)  :: noutbuf
2456    INTEGER    , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
2457    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
2458    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
2459    INTEGER    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(IN) :: inbuf
2460! Local
2461    INTEGER               :: i,j,k,n   ,  icurs
2462    icurs = 1
2463      DO k = PS3, PE3
2464        DO j = PS2, PE2
2465          DO i = PS1, PE1
2466            outbuf( icurs )  = inbuf( i, j, k )
2467            icurs = icurs + 1
2468          ENDDO
2469        ENDDO
2470      ENDDO
2471    RETURN
2472  END SUBROUTINE just_patch_i
2473
2474  SUBROUTINE just_patch_r ( inbuf , outbuf, noutbuf,     &
2475                               PS1,PE1,PS2,PE2,PS3,PE3,  &
2476                               MS1,ME1,MS2,ME2,MS3,ME3   )
2477    IMPLICIT NONE
2478    INTEGER                      , INTENT(IN)  :: noutbuf
2479    REAL    , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
2480    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
2481    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
2482    REAL    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(in) :: inbuf
2483! Local
2484    INTEGER               :: i,j,k   ,  icurs
2485    icurs = 1
2486      DO k = PS3, PE3
2487        DO j = PS2, PE2
2488          DO i = PS1, PE1
2489            outbuf( icurs )  = inbuf( i, j, k )
2490            icurs = icurs + 1
2491          ENDDO
2492        ENDDO
2493      ENDDO
2494    RETURN
2495  END SUBROUTINE just_patch_r
2496
2497  SUBROUTINE just_patch_d ( inbuf , outbuf, noutbuf,     &
2498                               PS1,PE1,PS2,PE2,PS3,PE3,  &
2499                               MS1,ME1,MS2,ME2,MS3,ME3   )
2500    IMPLICIT NONE
2501    INTEGER                                  , INTENT(IN)  :: noutbuf
2502    DOUBLE PRECISION    , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
2503    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
2504    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
2505    DOUBLE PRECISION    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(in) :: inbuf
2506! Local
2507    INTEGER               :: i,j,k,n   ,  icurs
2508    icurs = 1
2509      DO k = PS3, PE3
2510        DO j = PS2, PE2
2511          DO i = PS1, PE1
2512            outbuf( icurs )  = inbuf( i, j, k )
2513            icurs = icurs + 1
2514          ENDDO
2515        ENDDO
2516      ENDDO
2517    RETURN
2518  END SUBROUTINE just_patch_d
2519
2520  SUBROUTINE just_patch_l ( inbuf , outbuf, noutbuf,     &
2521                               PS1,PE1,PS2,PE2,PS3,PE3,  &
2522                               MS1,ME1,MS2,ME2,MS3,ME3   )
2523    IMPLICIT NONE
2524    INTEGER                         , INTENT(IN)  :: noutbuf
2525    LOGICAL    , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
2526    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
2527    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
2528    LOGICAL    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(in) :: inbuf
2529! Local
2530    INTEGER               :: i,j,k,n   ,  icurs
2531    icurs = 1
2532      DO k = PS3, PE3
2533        DO j = PS2, PE2
2534          DO i = PS1, PE1
2535            outbuf( icurs )  = inbuf( i, j, k )
2536            icurs = icurs + 1
2537          ENDDO
2538        ENDDO
2539      ENDDO
2540    RETURN
2541  END SUBROUTINE just_patch_l
2542
2543
2544  SUBROUTINE patch_2_outbuf_r( inbuf, outbuf,            &
2545                               DS1,DE1,DS2,DE2,DS3,DE3,  &
2546                               GPATCH )
2547    USE module_dm, ONLY : ntasks
2548    IMPLICIT NONE
2549    REAL    , DIMENSION(*) , INTENT(IN) :: inbuf
2550    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2551    REAL    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
2552! Local
2553    INTEGER               :: i,j,k,n   ,  icurs
2554    icurs = 1
2555    DO n = 1, ntasks
2556      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2557        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2558          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2559            outbuf( i, j, k ) = inbuf( icurs )
2560            icurs = icurs + 1
2561          ENDDO
2562        ENDDO
2563      ENDDO
2564    ENDDO
2565
2566    RETURN
2567  END SUBROUTINE patch_2_outbuf_r
2568
2569  SUBROUTINE patch_2_outbuf_i( inbuf, outbuf,         &
2570                               DS1,DE1,DS2,DE2,DS3,DE3,&
2571                               GPATCH )
2572    USE module_dm, ONLY : ntasks
2573    IMPLICIT NONE
2574    INTEGER    , DIMENSION(*) , INTENT(IN) :: inbuf
2575    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2576    INTEGER    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
2577! Local
2578    INTEGER               :: i,j,k,n   ,  icurs
2579    icurs = 1
2580    DO n = 1, ntasks
2581      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2582        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2583          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2584            outbuf( i, j, k ) = inbuf( icurs )
2585            icurs = icurs + 1
2586          ENDDO
2587        ENDDO
2588      ENDDO
2589    ENDDO
2590    RETURN
2591  END SUBROUTINE patch_2_outbuf_i
2592
2593  SUBROUTINE patch_2_outbuf_d( inbuf, outbuf,         &
2594                               DS1,DE1,DS2,DE2,DS3,DE3,&
2595                               GPATCH )
2596    USE module_dm, ONLY : ntasks
2597    IMPLICIT NONE
2598    DOUBLE PRECISION    , DIMENSION(*) , INTENT(IN) :: inbuf
2599    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2600    DOUBLE PRECISION    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
2601! Local
2602    INTEGER               :: i,j,k,n   ,  icurs
2603    icurs = 1
2604    DO n = 1, ntasks
2605      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2606        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2607          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2608            outbuf( i, j, k ) = inbuf( icurs )
2609            icurs = icurs + 1
2610          ENDDO
2611        ENDDO
2612      ENDDO
2613    ENDDO
2614    RETURN
2615  END SUBROUTINE patch_2_outbuf_d
2616
2617  SUBROUTINE patch_2_outbuf_l( inbuf, outbuf,         &
2618                               DS1,DE1,DS2,DE2,DS3,DE3,&
2619                               GPATCH )
2620    USE module_dm, ONLY : ntasks
2621    IMPLICIT NONE
2622    LOGICAL    , DIMENSION(*) , INTENT(IN) :: inbuf
2623    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2624    LOGICAL    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
2625! Local
2626    INTEGER               :: i,j,k,n   ,  icurs
2627    icurs = 1
2628    DO n = 1, ntasks
2629      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2630        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2631          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2632            outbuf( i, j, k ) = inbuf( icurs )
2633            icurs = icurs + 1
2634          ENDDO
2635        ENDDO
2636      ENDDO
2637    ENDDO
2638    RETURN
2639  END SUBROUTINE patch_2_outbuf_l
2640
2641!!!!!!!!!!!!!!!!!!!!!!! GLOBAL TO PATCH !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2642
2643    SUBROUTINE wrf_global_to_patch_real (globbuf,buf,domdesc,stagger,ordering,&
2644                                       DS1,DE1,DS2,DE2,DS3,DE3,&
2645                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2646                                       PS1,PE1,PS2,PE2,PS3,PE3 )
2647       IMPLICIT NONE
2648       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
2649                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2650                                       PS1,PE1,PS2,PE2,PS3,PE3
2651       CHARACTER *(*) stagger,ordering
2652       INTEGER fid,domdesc
2653       REAL globbuf(*)
2654       REAL buf(*)
2655
2656       CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,RWORDSIZE,&
2657                                       DS1,DE1,DS2,DE2,DS3,DE3,&
2658                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2659                                       PS1,PE1,PS2,PE2,PS3,PE3 )
2660       RETURN
2661    END SUBROUTINE wrf_global_to_patch_real
2662
2663    SUBROUTINE wrf_global_to_patch_double (globbuf,buf,domdesc,stagger,ordering,&
2664                                       DS1,DE1,DS2,DE2,DS3,DE3,&
2665                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2666                                       PS1,PE1,PS2,PE2,PS3,PE3 )
2667       IMPLICIT NONE
2668       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
2669                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2670                                       PS1,PE1,PS2,PE2,PS3,PE3
2671       CHARACTER *(*) stagger,ordering
2672       INTEGER fid,domdesc
2673! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
2674! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
2675! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
2676! since we were not indexing the globbuf and Field arrays it does not matter
2677       REAL globbuf(*)
2678       REAL buf(*)
2679
2680       CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,DWORDSIZE,&
2681                                       DS1,DE1,DS2,DE2,DS3,DE3,&
2682                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2683                                       PS1,PE1,PS2,PE2,PS3,PE3 )
2684       RETURN
2685    END SUBROUTINE wrf_global_to_patch_double
2686
2687
2688    SUBROUTINE wrf_global_to_patch_integer (globbuf,buf,domdesc,stagger,ordering,&
2689                                       DS1,DE1,DS2,DE2,DS3,DE3,&
2690                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2691                                       PS1,PE1,PS2,PE2,PS3,PE3 )
2692       IMPLICIT NONE
2693       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
2694                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2695                                       PS1,PE1,PS2,PE2,PS3,PE3
2696       CHARACTER *(*) stagger,ordering
2697       INTEGER fid,domdesc
2698       INTEGER globbuf(*)
2699       INTEGER buf(*)
2700
2701       CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,IWORDSIZE,&
2702                                       DS1,DE1,DS2,DE2,DS3,DE3,&
2703                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2704                                       PS1,PE1,PS2,PE2,PS3,PE3 )
2705       RETURN
2706    END SUBROUTINE wrf_global_to_patch_integer
2707
2708    SUBROUTINE wrf_global_to_patch_logical (globbuf,buf,domdesc,stagger,ordering,&
2709                                       DS1,DE1,DS2,DE2,DS3,DE3,&
2710                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2711                                       PS1,PE1,PS2,PE2,PS3,PE3 )
2712       IMPLICIT NONE
2713       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
2714                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2715                                       PS1,PE1,PS2,PE2,PS3,PE3
2716       CHARACTER *(*) stagger,ordering
2717       INTEGER fid,domdesc
2718       LOGICAL globbuf(*)
2719       LOGICAL buf(*)
2720
2721       CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,LWORDSIZE,&
2722                                       DS1,DE1,DS2,DE2,DS3,DE3,&
2723                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2724                                       PS1,PE1,PS2,PE2,PS3,PE3 )
2725       RETURN
2726    END SUBROUTINE wrf_global_to_patch_logical
2727
2728    SUBROUTINE wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,typesize,&
2729                                       DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
2730                                       MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
2731                                       PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
2732       USE module_dm, ONLY : local_communicator, ntasks
2733       USE module_driver_constants
2734       IMPLICIT NONE
2735       INTEGER                         DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
2736                                       MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
2737                                       PS1a,PE1a,PS2a,PE2a,PS3a,PE3A
2738       CHARACTER *(*) stagger,ordering
2739       INTEGER domdesc,typesize,ierr
2740       REAL globbuf(*)
2741       REAL buf(*)
2742#ifndef STUBMPI
2743       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
2744                                       MS1,ME1,MS2,ME2,MS3,ME3,&
2745                                       PS1,PE1,PS2,PE2,PS3,PE3
2746       LOGICAL, EXTERNAL :: wrf_dm_on_monitor, has_char
2747
2748       INTEGER i,j,k,ord,ord2d,ndim
2749       INTEGER  Patch(3,2), Gpatch(3,2,ntasks)
2750       REAL, ALLOCATABLE :: tmpbuf( : )
2751       REAL locbuf( (PE1a-PS1a+1)*(PE2a-PS2a+1)*(PE3a-PS3a+1)/RWORDSIZE*typesize+32 )
2752
2753       DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
2754       MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
2755       PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
2756
2757       SELECT CASE ( TRIM(ordering) )
2758         CASE ( 'xy', 'yx' )
2759           ndim = 2
2760         CASE DEFAULT
2761           ndim = 3   ! where appropriate
2762       END SELECT
2763
2764       SELECT CASE ( TRIM(ordering) )
2765         CASE ( 'xyz','xy' )
2766            ! the non-staggered variables come in at one-less than
2767            ! domain dimensions, but code wants full domain spec, so
2768            ! adjust if not staggered
2769           IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
2770           IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
2771           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
2772         CASE ( 'yxz','yx' )
2773           IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
2774           IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
2775           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
2776         CASE ( 'zxy' )
2777           IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
2778           IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
2779           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
2780         CASE ( 'xzy' )
2781           IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
2782           IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
2783           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
2784         CASE DEFAULT
2785       END SELECT
2786
2787     ! moved to here to be after the potential recalculations of D dims
2788       IF ( wrf_dm_on_monitor() ) THEN
2789         ALLOCATE ( tmpbuf ( (DE1-DS1+1)*(DE2-DS2+1)*(DE3-DS3+1)/RWORDSIZE*typesize+32 ), STAT=ierr )
2790       ELSE
2791         ALLOCATE ( tmpbuf ( 1 ), STAT=ierr )
2792       ENDIF
2793       IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating tmpbuf in wrf_global_to_patch_generic')
2794
2795       Patch(1,1) = ps1 ; Patch(1,2) = pe1    ! use patch dims
2796       Patch(2,1) = ps2 ; Patch(2,2) = pe2
2797       Patch(3,1) = ps3 ; Patch(3,2) = pe3
2798
2799! defined in external/io_quilt
2800       CALL collect_on_comm0 (  local_communicator , IWORDSIZE ,  &
2801                                Patch , 6 ,                       &
2802                                GPatch , 6*ntasks                 )
2803       ndim = len(TRIM(ordering))
2804
2805       IF ( wrf_dm_on_monitor() .AND. ndim .GE. 2 ) THEN
2806         IF      ( typesize .EQ. RWORDSIZE ) THEN
2807           CALL outbuf_2_patch_r ( globbuf , tmpbuf FRSTELEM ,    &
2808                                   DS1, DE1, DS2, DE2, DS3, DE3 , &
2809                                   MS1, ME1, MS2, ME2, MS3, ME3 , &
2810                                   GPATCH                         )
2811         ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
2812           CALL outbuf_2_patch_i ( globbuf , tmpbuf FRSTELEM ,    &
2813                                   DS1, DE1, DS2, DE2, DS3, DE3 , &
2814                                   GPATCH                         )
2815         ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
2816           CALL outbuf_2_patch_d ( globbuf , tmpbuf FRSTELEM ,    &
2817                                   DS1, DE1, DS2, DE2, DS3, DE3 , &
2818                                   GPATCH                         )
2819         ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
2820           CALL outbuf_2_patch_l ( globbuf , tmpbuf FRSTELEM ,    &
2821                                   DS1, DE1, DS2, DE2, DS3, DE3 , &
2822                                   GPATCH                         )
2823         ENDIF
2824       ENDIF
2825
2826       CALL dist_on_comm0 (  local_communicator , typesize ,  &
2827                             tmpbuf FRSTELEM , (de1-ds1+1)*(de2-ds2+1)*(de3-ds3+1) , &
2828                             locbuf    , (pe1-ps1+1)*(pe2-ps2+1)*(pe3-ps3+1) )
2829
2830       IF      ( typesize .EQ. RWORDSIZE ) THEN
2831         CALL all_sub_r ( locbuf , buf ,             &
2832                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
2833                                   MS1, ME1, MS2, ME2, MS3, ME3   )
2834
2835       ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
2836         CALL all_sub_i ( locbuf , buf ,             &
2837                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
2838                                   MS1, ME1, MS2, ME2, MS3, ME3   )
2839       ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
2840         CALL all_sub_d ( locbuf , buf ,             &
2841                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
2842                                   MS1, ME1, MS2, ME2, MS3, ME3   )
2843       ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
2844         CALL all_sub_l ( locbuf , buf ,             &
2845                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
2846                                   MS1, ME1, MS2, ME2, MS3, ME3   )
2847       ENDIF
2848
2849
2850       DEALLOCATE ( tmpbuf )
2851#endif
2852       RETURN
2853    END SUBROUTINE wrf_global_to_patch_generic
2854
2855  SUBROUTINE all_sub_i ( inbuf , outbuf,              &
2856                               PS1,PE1,PS2,PE2,PS3,PE3,  &
2857                               MS1,ME1,MS2,ME2,MS3,ME3   )
2858    IMPLICIT NONE
2859    INTEGER    , DIMENSION(*) , INTENT(IN) :: inbuf
2860    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
2861    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
2862    INTEGER    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
2863! Local
2864    INTEGER               :: i,j,k,n   ,  icurs
2865    icurs = 1
2866      DO k = PS3, PE3
2867        DO j = PS2, PE2
2868          DO i = PS1, PE1
2869            outbuf( i, j, k )  = inbuf ( icurs )
2870            icurs = icurs + 1
2871          ENDDO
2872        ENDDO
2873      ENDDO
2874    RETURN
2875  END SUBROUTINE all_sub_i
2876
2877  SUBROUTINE all_sub_r ( inbuf , outbuf,              &
2878                               PS1,PE1,PS2,PE2,PS3,PE3,  &
2879                               MS1,ME1,MS2,ME2,MS3,ME3   )
2880    IMPLICIT NONE
2881    REAL       , DIMENSION(*) , INTENT(IN) :: inbuf
2882    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
2883    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
2884    REAL       , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
2885! Local
2886    INTEGER               :: i,j,k,n   ,  icurs
2887    icurs = 1
2888      DO k = PS3, PE3
2889        DO j = PS2, PE2
2890          DO i = PS1, PE1
2891            outbuf( i, j, k )  = inbuf ( icurs )
2892            icurs = icurs + 1
2893          ENDDO
2894        ENDDO
2895      ENDDO
2896
2897    RETURN
2898  END SUBROUTINE all_sub_r
2899
2900  SUBROUTINE all_sub_d ( inbuf , outbuf,              &
2901                               PS1,PE1,PS2,PE2,PS3,PE3,  &
2902                               MS1,ME1,MS2,ME2,MS3,ME3   )
2903    IMPLICIT NONE
2904    DOUBLE PRECISION    , DIMENSION(*) , INTENT(IN) :: inbuf
2905    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
2906    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
2907    DOUBLE PRECISION    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
2908! Local
2909    INTEGER               :: i,j,k,n   ,  icurs
2910    icurs = 1
2911      DO k = PS3, PE3
2912        DO j = PS2, PE2
2913          DO i = PS1, PE1
2914            outbuf( i, j, k )  = inbuf ( icurs )
2915            icurs = icurs + 1
2916          ENDDO
2917        ENDDO
2918      ENDDO
2919    RETURN
2920  END SUBROUTINE all_sub_d
2921
2922  SUBROUTINE all_sub_l ( inbuf , outbuf,              &
2923                               PS1,PE1,PS2,PE2,PS3,PE3,  &
2924                               MS1,ME1,MS2,ME2,MS3,ME3   )
2925    IMPLICIT NONE
2926    LOGICAL    , DIMENSION(*) , INTENT(IN) :: inbuf
2927    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
2928    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
2929    LOGICAL    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
2930! Local
2931    INTEGER               :: i,j,k,n   ,  icurs
2932    icurs = 1
2933      DO k = PS3, PE3
2934        DO j = PS2, PE2
2935          DO i = PS1, PE1
2936            outbuf( i, j, k )  = inbuf ( icurs )
2937            icurs = icurs + 1
2938          ENDDO
2939        ENDDO
2940      ENDDO
2941    RETURN
2942  END SUBROUTINE all_sub_l
2943
2944  SUBROUTINE outbuf_2_patch_r( inbuf, outbuf,         &
2945                               DS1,DE1,DS2,DE2,DS3,DE3, &
2946                               MS1, ME1, MS2, ME2, MS3, ME3 , &
2947                               GPATCH )
2948    USE module_dm, ONLY : ntasks
2949    IMPLICIT NONE
2950    REAL    , DIMENSION(*) , INTENT(OUT) :: outbuf
2951    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2952    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
2953    REAL    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
2954! Local
2955    INTEGER               :: i,j,k,n   ,  icurs
2956
2957    icurs = 1
2958    DO n = 1, ntasks
2959      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2960        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2961          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2962            outbuf( icurs ) = inbuf( i,j,k )
2963            icurs = icurs + 1
2964          ENDDO
2965        ENDDO
2966      ENDDO
2967    ENDDO
2968    RETURN
2969  END SUBROUTINE outbuf_2_patch_r
2970
2971  SUBROUTINE outbuf_2_patch_i( inbuf, outbuf,         &
2972                               DS1,DE1,DS2,DE2,DS3,DE3,&
2973                               GPATCH )
2974    USE module_dm, ONLY : ntasks
2975    IMPLICIT NONE
2976    INTEGER    , DIMENSION(*) , INTENT(OUT) :: outbuf
2977    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
2978    INTEGER    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
2979! Local
2980    INTEGER               :: i,j,k,n   ,  icurs
2981    icurs = 1
2982    DO n = 1, ntasks
2983      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
2984        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
2985          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
2986            outbuf( icurs ) = inbuf( i,j,k )
2987            icurs = icurs + 1
2988          ENDDO
2989        ENDDO
2990      ENDDO
2991    ENDDO
2992    RETURN
2993  END SUBROUTINE outbuf_2_patch_i
2994
2995  SUBROUTINE outbuf_2_patch_d( inbuf, outbuf,         &
2996                               DS1,DE1,DS2,DE2,DS3,DE3,&
2997                               GPATCH )
2998    USE module_dm, ONLY : ntasks
2999    IMPLICIT NONE
3000    DOUBLE PRECISION    , DIMENSION(*) , INTENT(OUT) :: outbuf
3001    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
3002    DOUBLE PRECISION    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
3003! Local
3004    INTEGER               :: i,j,k,n   ,  icurs
3005    icurs = 1
3006    DO n = 1, ntasks
3007      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
3008        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
3009          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
3010            outbuf( icurs ) = inbuf( i,j,k )
3011            icurs = icurs + 1
3012          ENDDO
3013        ENDDO
3014      ENDDO
3015    ENDDO
3016    RETURN
3017  END SUBROUTINE outbuf_2_patch_d
3018
3019  SUBROUTINE outbuf_2_patch_l( inbuf, outbuf,         &
3020                               DS1,DE1,DS2,DE2,DS3,DE3,&
3021                               GPATCH )
3022    USE module_dm, ONLY : ntasks
3023    IMPLICIT NONE
3024    LOGICAL    , DIMENSION(*) , INTENT(OUT) :: outbuf
3025    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
3026    LOGICAL    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
3027! Local
3028    INTEGER               :: i,j,k,n   ,  icurs
3029    icurs = 1
3030    DO n = 1, ntasks
3031      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
3032        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
3033          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
3034            outbuf( icurs ) = inbuf( i,j,k )
3035            icurs = icurs + 1
3036          ENDDO
3037        ENDDO
3038      ENDDO
3039    ENDDO
3040    RETURN
3041  END SUBROUTINE outbuf_2_patch_l
3042
3043
3044
3045!------------------------------------------------------------------
3046
3047#if ( EM_CORE == 1 && DA_CORE != 1 )
3048
3049!------------------------------------------------------------------
3050
3051   SUBROUTINE force_domain_em_part2 ( grid, ngrid, config_flags    &
3052!
3053#include "dummy_new_args.inc"
3054!
3055                 )
3056      USE module_state_description
3057      USE module_domain, ONLY : domain, get_ijk_from_grid
3058      USE module_configure, ONLY : grid_config_rec_type
3059      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, local_communicator, mytask
3060      USE module_comm_nesting_dm, ONLY : halo_force_down_sub
3061      IMPLICIT NONE
3062!
3063      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
3064      TYPE(domain), POINTER :: ngrid
3065#include <dummy_new_decl.inc>
3066      INTEGER nlev, msize
3067      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3068      TYPE (grid_config_rec_type)            :: config_flags
3069      REAL xv(500)
3070      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
3071                                cims, cime, cjms, cjme, ckms, ckme,    &
3072                                cips, cipe, cjps, cjpe, ckps, ckpe
3073      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
3074                                nims, nime, njms, njme, nkms, nkme,    &
3075                                nips, nipe, njps, njpe, nkps, nkpe
3076      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
3077                                ims, ime, jms, jme, kms, kme,    &
3078                                ips, ipe, jps, jpe, kps, kpe
3079      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7,itrace
3080      REAL  dummy_xs, dummy_xe, dummy_ys, dummy_ye
3081
3082      CALL get_ijk_from_grid (  grid ,                   &
3083                                cids, cide, cjds, cjde, ckds, ckde,    &
3084                                cims, cime, cjms, cjme, ckms, ckme,    &
3085                                cips, cipe, cjps, cjpe, ckps, ckpe    )
3086      CALL get_ijk_from_grid (  ngrid ,              &
3087                                nids, nide, njds, njde, nkds, nkde,    &
3088                                nims, nime, njms, njme, nkms, nkme,    &
3089                                nips, nipe, njps, njpe, nkps, nkpe    )
3090
3091      nlev  = ckde - ckds + 1
3092
3093#include "nest_interpdown_unpack.inc"
3094
3095      CALL get_ijk_from_grid (  grid ,              &
3096                                ids, ide, jds, jde, kds, kde,    &
3097                                ims, ime, jms, jme, kms, kme,    &
3098                                ips, ipe, jps, jpe, kps, kpe    )
3099
3100#include "HALO_FORCE_DOWN.inc"
3101
3102      ! code here to interpolate the data into the nested domain
3103#  include "nest_forcedown_interp.inc"
3104
3105      RETURN
3106   END SUBROUTINE force_domain_em_part2
3107
3108!------------------------------------------------------------------
3109
3110   SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags    &
3111!
3112#include "dummy_new_args.inc"
3113!
3114                 )
3115      USE module_state_description
3116      USE module_domain, ONLY : domain, get_ijk_from_grid
3117      USE module_configure, ONLY : grid_config_rec_type
3118      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, &
3119                            mytask, get_dm_max_halo_width
3120      USE module_timing
3121      IMPLICIT NONE
3122!
3123      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
3124      TYPE(domain), POINTER :: intermediate_grid
3125      TYPE(domain), POINTER :: ngrid
3126#include <dummy_new_decl.inc>
3127      INTEGER nlev, msize
3128      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3129      INTEGER iparstrt,jparstrt,sw
3130      TYPE (grid_config_rec_type)            :: config_flags
3131      REAL xv(500)
3132      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
3133                                cims, cime, cjms, cjme, ckms, ckme,    &
3134                                cips, cipe, cjps, cjpe, ckps, ckpe
3135      INTEGER       ::          iids, iide, ijds, ijde, ikds, ikde,    &
3136                                iims, iime, ijms, ijme, ikms, ikme,    &
3137                                iips, iipe, ijps, ijpe, ikps, ikpe
3138      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
3139                                nims, nime, njms, njme, nkms, nkme,    &
3140                                nips, nipe, njps, njpe, nkps, nkpe
3141
3142      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
3143
3144      INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr
3145      INTEGER thisdomain_max_halo_width
3146      INTEGER local_comm, myproc, nproc
3147
3148      CALL wrf_get_dm_communicator ( local_comm )
3149      CALL wrf_get_myproc( myproc )
3150      CALL wrf_get_nproc( nproc )
3151
3152      CALL get_ijk_from_grid (  grid ,                   &
3153                                cids, cide, cjds, cjde, ckds, ckde,    &
3154                                cims, cime, cjms, cjme, ckms, ckme,    &
3155                                cips, cipe, cjps, cjpe, ckps, ckpe    )
3156      CALL get_ijk_from_grid (  intermediate_grid ,              &
3157                                iids, iide, ijds, ijde, ikds, ikde,    &
3158                                iims, iime, ijms, ijme, ikms, ikme,    &
3159                                iips, iipe, ijps, ijpe, ikps, ikpe    )
3160      CALL get_ijk_from_grid (  ngrid ,              &
3161                                nids, nide, njds, njde, nkds, nkde,    &
3162                                nims, nime, njms, njme, nkms, nkme,    &
3163                                nips, nipe, njps, njpe, nkps, nkpe    )
3164
3165      CALL nl_get_parent_grid_ratio ( ngrid%id, pgr )
3166      CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
3167      CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
3168      CALL nl_get_shw            ( intermediate_grid%id, sw )
3169      icoord =    iparstrt - sw
3170      jcoord =    jparstrt - sw
3171      idim_cd = iide - iids + 1
3172      jdim_cd = ijde - ijds + 1
3173
3174      nlev  = ckde - ckds + 1
3175
3176      ! get max_halo_width for parent. It may be smaller if it is moad
3177      CALL get_dm_max_halo_width ( grid%id , thisdomain_max_halo_width )
3178
3179#include "nest_interpdown_pack.inc"
3180
3181      CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm )
3182
3183      RETURN
3184   END SUBROUTINE interp_domain_em_part1
3185
3186!------------------------------------------------------------------
3187
3188   SUBROUTINE interp_domain_em_part2 ( grid, ngrid, config_flags    &
3189!
3190#include "dummy_new_args.inc"
3191!
3192                 )
3193      USE module_state_description
3194      USE module_domain, ONLY : domain, get_ijk_from_grid
3195      USE module_configure, ONLY : grid_config_rec_type
3196      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, &
3197                            mytask, get_dm_max_halo_width
3198      USE module_comm_nesting_dm, ONLY : halo_interp_down_sub
3199      IMPLICIT NONE
3200!
3201      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
3202      TYPE(domain), POINTER :: ngrid
3203#include <dummy_new_decl.inc>
3204      INTEGER nlev, msize
3205      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3206      TYPE (grid_config_rec_type)            :: config_flags
3207      REAL xv(500)
3208      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
3209                                cims, cime, cjms, cjme, ckms, ckme,    &
3210                                cips, cipe, cjps, cjpe, ckps, ckpe
3211      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
3212                                nims, nime, njms, njme, nkms, nkme,    &
3213                                nips, nipe, njps, njpe, nkps, nkpe
3214      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
3215                                ims, ime, jms, jme, kms, kme,    &
3216                                ips, ipe, jps, jpe, kps, kpe
3217
3218      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
3219
3220      INTEGER myproc
3221      INTEGER ierr
3222      INTEGER thisdomain_max_halo_width
3223
3224      CALL get_ijk_from_grid (  grid ,                   &
3225                                cids, cide, cjds, cjde, ckds, ckde,    &
3226                                cims, cime, cjms, cjme, ckms, ckme,    &
3227                                cips, cipe, cjps, cjpe, ckps, ckpe    )
3228      CALL get_ijk_from_grid (  ngrid ,              &
3229                                nids, nide, njds, njde, nkds, nkde,    &
3230                                nims, nime, njms, njme, nkms, nkme,    &
3231                                nips, nipe, njps, njpe, nkps, nkpe    )
3232
3233      nlev  = ckde - ckds + 1
3234
3235      CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width )
3236
3237#include "nest_interpdown_unpack.inc"
3238
3239      CALL get_ijk_from_grid (  grid ,              &
3240                                ids, ide, jds, jde, kds, kde,    &
3241                                ims, ime, jms, jme, kms, kme,    &
3242                                ips, ipe, jps, jpe, kps, kpe    )
3243
3244#include "HALO_INTERP_DOWN.inc"
3245
3246#  include "nest_interpdown_interp.inc"
3247
3248      RETURN
3249   END SUBROUTINE interp_domain_em_part2
3250
3251!------------------------------------------------------------------
3252
3253   SUBROUTINE feedback_nest_prep ( grid, config_flags    &
3254!
3255#include "dummy_new_args.inc"
3256!
3257)
3258      USE module_state_description
3259      USE module_domain, ONLY : domain, get_ijk_from_grid
3260      USE module_configure, ONLY : grid_config_rec_type
3261      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask
3262      USE module_comm_nesting_dm, ONLY : halo_interp_up_sub
3263      IMPLICIT NONE
3264!
3265      TYPE(domain), TARGET :: grid          ! name of the grid being dereferenced (must be "grid")
3266      TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of
3267                                                  ! soil temp, moisture, etc., has vertical dim
3268                                                  ! of soil categories
3269#include <dummy_new_decl.inc>
3270
3271      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
3272                                ims, ime, jms, jme, kms, kme,    &
3273                                ips, ipe, jps, jpe, kps, kpe
3274
3275      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
3276
3277      INTEGER       :: idum1, idum2
3278
3279
3280      CALL get_ijk_from_grid (  grid ,              &
3281                                ids, ide, jds, jde, kds, kde,    &
3282                                ims, ime, jms, jme, kms, kme,    &
3283                                ips, ipe, jps, jpe, kps, kpe    )
3284
3285#ifdef DM_PARALLEL
3286#include "HALO_INTERP_UP.inc"
3287#endif
3288
3289   END SUBROUTINE feedback_nest_prep
3290
3291!------------------------------------------------------------------
3292
3293   SUBROUTINE feedback_domain_em_part1 ( grid, ngrid, config_flags    &
3294!
3295#include "dummy_new_args.inc"
3296!
3297                 )
3298      USE module_state_description
3299      USE module_domain, ONLY : domain, get_ijk_from_grid
3300      USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec
3301      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
3302                            ipe_save, jpe_save, ips_save, jps_save
3303 
3304      IMPLICIT NONE
3305!
3306      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
3307      TYPE(domain), POINTER :: ngrid
3308#include <dummy_new_decl.inc>
3309      INTEGER nlev, msize
3310      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3311      TYPE(domain), POINTER :: xgrid
3312      TYPE (grid_config_rec_type)            :: config_flags, nconfig_flags
3313      REAL xv(500)
3314      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
3315                                cims, cime, cjms, cjme, ckms, ckme,    &
3316                                cips, cipe, cjps, cjpe, ckps, ckpe
3317      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
3318                                nims, nime, njms, njme, nkms, nkme,    &
3319                                nips, nipe, njps, njpe, nkps, nkpe
3320
3321      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
3322
3323      INTEGER local_comm, myproc, nproc, idum1, idum2
3324      INTEGER thisdomain_max_halo_width
3325
3326      INTERFACE
3327          SUBROUTINE feedback_nest_prep ( grid, config_flags    &
3328!
3329#include "dummy_new_args.inc"
3330!
3331)
3332             USE module_state_description
3333             USE module_domain, ONLY : domain
3334             USE module_configure, ONLY : grid_config_rec_type
3335!
3336             TYPE (grid_config_rec_type)            :: config_flags
3337             TYPE(domain), TARGET                   :: grid
3338#include <dummy_new_decl.inc>
3339          END SUBROUTINE feedback_nest_prep
3340      END INTERFACE
3341!
3342
3343      CALL wrf_get_dm_communicator ( local_comm )
3344      CALL wrf_get_myproc( myproc )
3345      CALL wrf_get_nproc( nproc )
3346
3347!
3348! intermediate grid
3349      CALL get_ijk_from_grid (  grid ,                                 &
3350                                cids, cide, cjds, cjde, ckds, ckde,    &
3351                                cims, cime, cjms, cjme, ckms, ckme,    &
3352                                cips, cipe, cjps, cjpe, ckps, ckpe    )
3353! nest grid
3354      CALL get_ijk_from_grid (  ngrid ,                                &
3355                                nids, nide, njds, njde, nkds, nkde,    &
3356                                nims, nime, njms, njme, nkms, nkme,    &
3357                                nips, nipe, njps, njpe, nkps, nkpe    )
3358
3359      nlev  = ckde - ckds + 1
3360
3361      ips_save = ngrid%i_parent_start   ! used in feedback_domain_em_part2 below
3362      jps_save = ngrid%j_parent_start
3363      ipe_save = ngrid%i_parent_start + (nide-nids+1) / ngrid%parent_grid_ratio - 1
3364      jpe_save = ngrid%j_parent_start + (njde-njds+1) / ngrid%parent_grid_ratio - 1
3365
3366! feedback_nest_prep invokes a halo exchange on the ngrid. It is done this way
3367! in a separate routine because the HALOs need the data to be dereference from the
3368! grid data structure and, in this routine, the dereferenced fields are related to
3369! the intermediate domain, not the nest itself. Save the current grid pointer to intermediate
3370! domain, switch grid to point to ngrid, invoke feedback_nest_prep,  then restore grid
3371! to point to intermediate domain.
3372
3373      CALL model_to_grid_config_rec ( ngrid%id , model_config_rec , nconfig_flags )
3374      CALL set_scalar_indices_from_config ( ngrid%id , idum1 , idum2 )
3375      xgrid => grid
3376      grid => ngrid
3377
3378      CALL feedback_nest_prep ( grid, nconfig_flags    &
3379!
3380#include "actual_new_args.inc"
3381!
3382)
3383
3384! put things back so grid is intermediate grid
3385
3386      grid => xgrid
3387      CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
3388
3389! "interp" (basically copy) ngrid onto intermediate grid
3390
3391#include "nest_feedbackup_interp.inc"
3392
3393      RETURN
3394   END SUBROUTINE feedback_domain_em_part1
3395
3396!------------------------------------------------------------------
3397
3398   SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_flags    &
3399!
3400#include "dummy_new_args.inc"
3401!
3402                 )
3403      USE module_state_description
3404      USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid
3405      USE module_configure, ONLY : grid_config_rec_type, model_config_rec
3406      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
3407                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
3408      USE module_comm_nesting_dm, ONLY : halo_interp_up_sub
3409      USE module_utility
3410      IMPLICIT NONE
3411
3412!
3413      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
3414      TYPE(domain), POINTER :: intermediate_grid
3415      TYPE(domain), POINTER :: ngrid
3416
3417#include <dummy_new_decl.inc>
3418      INTEGER nlev, msize
3419      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3420      TYPE (grid_config_rec_type)            :: config_flags
3421      REAL xv(500)
3422      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
3423                                cims, cime, cjms, cjme, ckms, ckme,    &
3424                                cips, cipe, cjps, cjpe, ckps, ckpe
3425      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
3426                                nims, nime, njms, njme, nkms, nkme,    &
3427                                nips, nipe, njps, njpe, nkps, nkpe
3428      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
3429                                ims, ime, jms, jme, kms, kme,    &
3430                                ips, ipe, jps, jpe, kps, kpe
3431
3432      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
3433
3434      INTEGER icoord, jcoord, idim_cd, jdim_cd
3435      INTEGER local_comm, myproc, nproc
3436      INTEGER iparstrt, jparstrt, sw, thisdomain_max_halo_width
3437      REAL    nest_influence
3438
3439      character*256 :: timestr
3440      integer ierr
3441
3442      LOGICAL, EXTERNAL  :: cd_feedback_mask
3443
3444! On entry to this routine,
3445!  "grid" refers to the parent domain
3446!  "intermediate_grid" refers to local copy of parent domain that overlies this patch of nest
3447!  "ngrid" refers to the nest, which is only needed for smoothing on the parent because
3448!          the nest feedback data has already been transferred during em_nest_feedbackup_interp
3449!          in part1, above.
3450! The way these settings c and n dimensions are set, below, looks backwards but from the point
3451! of view of the RSL routine rsl_lite_to_parent_info(), call to which is included by
3452! em_nest_feedbackup_pack, the "n" domain represents the parent domain and the "c" domain
3453! represents the intermediate domain. The backwards lookingness should be fixed in the gen_comms.c
3454! registry routine that accompanies RSL_LITE but, just as it's sometimes easier to put up a road
3455! sign that says "DIP" than fix the dip,  at this point it was easier just to write this comment. JM
3456!
3457      nest_influence = 1.
3458
3459      CALL domain_clock_get( grid, current_timestr=timestr )
3460
3461      CALL get_ijk_from_grid (  intermediate_grid ,                   &
3462                                cids, cide, cjds, cjde, ckds, ckde,    &
3463                                cims, cime, cjms, cjme, ckms, ckme,    &
3464                                cips, cipe, cjps, cjpe, ckps, ckpe    )
3465      CALL get_ijk_from_grid (  grid ,              &
3466                                nids, nide, njds, njde, nkds, nkde,    &
3467                                nims, nime, njms, njme, nkms, nkme,    &
3468                                nips, nipe, njps, njpe, nkps, nkpe    )
3469
3470      CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
3471      CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
3472      CALL nl_get_shw            ( intermediate_grid%id, sw )
3473      icoord =    iparstrt - sw
3474      jcoord =    jparstrt - sw
3475      idim_cd = cide - cids + 1
3476      jdim_cd = cjde - cjds + 1
3477
3478      nlev  = ckde - ckds + 1
3479
3480      CALL get_dm_max_halo_width ( grid%id , thisdomain_max_halo_width )
3481
3482#include "nest_feedbackup_pack.inc"
3483
3484      CALL wrf_get_dm_communicator ( local_comm )
3485      CALL wrf_get_myproc( myproc )
3486      CALL wrf_get_nproc( nproc )
3487
3488      CALL rsl_lite_merge_msgs( myproc, nproc, local_comm )
3489
3490#define NEST_INFLUENCE(A,B) A = B
3491#include "nest_feedbackup_unpack.inc"
3492
3493      ! smooth coarse grid
3494      CALL get_ijk_from_grid (  ngrid,                           &
3495                                nids, nide, njds, njde, nkds, nkde,    &
3496                                nims, nime, njms, njme, nkms, nkme,    &
3497                                nips, nipe, njps, njpe, nkps, nkpe    )
3498      CALL get_ijk_from_grid (  grid ,              &
3499                                ids, ide, jds, jde, kds, kde,    &
3500                                ims, ime, jms, jme, kms, kme,    &
3501                                ips, ipe, jps, jpe, kps, kpe    )
3502
3503#include "HALO_INTERP_UP.inc"
3504
3505      CALL get_ijk_from_grid (  grid ,                   &
3506                                cids, cide, cjds, cjde, ckds, ckde,    &
3507                                cims, cime, cjms, cjme, ckms, ckme,    &
3508                                cips, cipe, cjps, cjpe, ckps, ckpe    )
3509
3510#include "nest_feedbackup_smooth.inc"
3511
3512      RETURN
3513   END SUBROUTINE feedback_domain_em_part2
3514#endif
3515
3516#if ( NMM_CORE == 1 && NMM_NEST == 1 )
3517!==============================================================================
3518! NMM nesting infrastructure extended from EM core. This is gopal's doing.
3519!==============================================================================
3520
3521   SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags    &
3522!
3523#include "dummy_new_args.inc"
3524!
3525                 )
3526      USE module_state_description
3527      USE module_domain, ONLY : domain, get_ijk_from_grid
3528      USE module_configure, ONLY : grid_config_rec_type
3529      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
3530                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
3531      USE module_timing
3532      IMPLICIT NONE
3533!
3534      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
3535      TYPE(domain), POINTER :: intermediate_grid
3536      TYPE(domain), POINTER :: ngrid
3537#include <dummy_new_decl.inc>
3538      INTEGER nlev, msize
3539      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3540      INTEGER iparstrt,jparstrt,sw
3541      TYPE (grid_config_rec_type)            :: config_flags
3542      REAL xv(500)
3543      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
3544                                cims, cime, cjms, cjme, ckms, ckme,    &
3545                                cips, cipe, cjps, cjpe, ckps, ckpe
3546      INTEGER       ::          iids, iide, ijds, ijde, ikds, ikde,    &
3547                                iims, iime, ijms, ijme, ikms, ikme,    &
3548                                iips, iipe, ijps, ijpe, ikps, ikpe
3549      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
3550                                nims, nime, njms, njme, nkms, nkme,    &
3551                                nips, nipe, njps, njpe, nkps, nkpe
3552
3553      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
3554
3555      INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr
3556      INTEGER local_comm, myproc, nproc
3557      INTEGER thisdomain_max_halo_width
3558
3559      CALL wrf_get_dm_communicator ( local_comm )
3560      CALL wrf_get_myproc( myproc )
3561      CALL wrf_get_nproc( nproc )
3562
3563!#define COPY_IN
3564!#include <scalar_derefs.inc>
3565
3566      CALL get_ijk_from_grid (  grid ,                   &
3567                                cids, cide, cjds, cjde, ckds, ckde,    &
3568                                cims, cime, cjms, cjme, ckms, ckme,    &
3569                                cips, cipe, cjps, cjpe, ckps, ckpe    )
3570      CALL get_ijk_from_grid (  intermediate_grid ,              &
3571                                iids, iide, ijds, ijde, ikds, ikde,    &
3572                                iims, iime, ijms, ijme, ikms, ikme,    &
3573                                iips, iipe, ijps, ijpe, ikps, ikpe    )
3574      CALL get_ijk_from_grid (  ngrid ,              &
3575                                nids, nide, njds, njde, nkds, nkde,    &
3576                                nims, nime, njms, njme, nkms, nkme,    &
3577                                nips, nipe, njps, njpe, nkps, nkpe    )
3578
3579      CALL nl_get_parent_grid_ratio ( ngrid%id, pgr )
3580      CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
3581      CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
3582      CALL nl_get_shw            ( intermediate_grid%id, sw )
3583      icoord =    iparstrt - sw
3584      jcoord =    jparstrt - sw
3585      idim_cd = iide - iids + 1
3586      jdim_cd = ijde - ijds + 1
3587
3588      nlev  = ckde - ckds + 1
3589
3590      CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width )
3591#include "nest_interpdown_pack.inc"
3592
3593      CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm )
3594
3595!#define COPY_OUT
3596!#include <scalar_derefs.inc>
3597      RETURN
3598   END SUBROUTINE interp_domain_nmm_part1
3599
3600!------------------------------------------------------------------
3601
3602   SUBROUTINE interp_domain_nmm_part2 ( grid, ngrid, config_flags    &
3603!
3604#include "dummy_new_args.inc"
3605!
3606                 )
3607      USE module_state_description
3608      USE module_domain, ONLY : domain, get_ijk_from_grid
3609      USE module_configure, ONLY : grid_config_rec_type
3610      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
3611                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
3612      USE module_comm_nesting_dm, ONLY : halo_interp_down_sub
3613      IMPLICIT NONE
3614!
3615      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
3616      TYPE(domain), POINTER :: ngrid
3617#include <dummy_new_decl.inc>
3618      INTEGER nlev, msize
3619      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3620      TYPE (grid_config_rec_type)            :: config_flags
3621      REAL xv(500)
3622      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
3623                                cims, cime, cjms, cjme, ckms, ckme,    &
3624                                cips, cipe, cjps, cjpe, ckps, ckpe
3625      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
3626                                nims, nime, njms, njme, nkms, nkme,    &
3627                                nips, nipe, njps, njpe, nkps, nkpe
3628      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
3629                                ims, ime, jms, jme, kms, kme,    &
3630                                ips, ipe, jps, jpe, kps, kpe
3631
3632      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
3633
3634      INTEGER myproc
3635      INTEGER ierr
3636
3637!#ifdef DEREF_KLUDGE
3638!!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
3639!   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
3640!   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
3641!   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
3642!#endif
3643#include "deref_kludge.h"
3644
3645!#define COPY_IN
3646!#include <scalar_derefs.inc>
3647      CALL get_ijk_from_grid (  grid ,                   &
3648                                cids, cide, cjds, cjde, ckds, ckde,    &
3649                                cims, cime, cjms, cjme, ckms, ckme,    &
3650                                cips, cipe, cjps, cjpe, ckps, ckpe    )
3651      CALL get_ijk_from_grid (  ngrid ,              &
3652                                nids, nide, njds, njde, nkds, nkde,    &
3653                                nims, nime, njms, njme, nkms, nkme,    &
3654                                nips, nipe, njps, njpe, nkps, nkpe    )
3655
3656      nlev  = ckde - ckds + 1
3657
3658#include "nest_interpdown_unpack.inc"
3659
3660      CALL get_ijk_from_grid (  grid ,              &
3661                                ids, ide, jds, jde, kds, kde,    &
3662                                ims, ime, jms, jme, kms, kme,    &
3663                                ips, ipe, jps, jpe, kps, kpe    )
3664
3665#include "HALO_INTERP_DOWN.inc"
3666
3667#include "nest_interpdown_interp.inc"
3668
3669!#define COPY_OUT
3670!#include <scalar_derefs.inc>
3671
3672      RETURN
3673   END SUBROUTINE interp_domain_nmm_part2
3674
3675!------------------------------------------------------------------
3676
3677   SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, config_flags    &
3678!
3679#include "dummy_new_args.inc"
3680!
3681                 )
3682      USE module_state_description
3683      USE module_domain, ONLY : domain, get_ijk_from_grid
3684      USE module_configure, ONLY : grid_config_rec_type
3685      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
3686                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
3687      USE module_timing
3688!
3689      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
3690      TYPE(domain), POINTER :: intermediate_grid
3691#include <dummy_new_decl.inc>
3692      INTEGER nlev, msize
3693      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3694      TYPE (grid_config_rec_type)            :: config_flags
3695      REAL xv(500)
3696      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
3697                                cims, cime, cjms, cjme, ckms, ckme,    &
3698                                cips, cipe, cjps, cjpe, ckps, ckpe
3699      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
3700                                nims, nime, njms, njme, nkms, nkme,    &
3701                                nips, nipe, njps, njpe, nkps, nkpe
3702
3703      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
3704
3705!#define COPY_IN
3706!#include <scalar_derefs.inc>
3707!
3708      CALL get_ijk_from_grid (  grid ,                   &
3709                                cids, cide, cjds, cjde, ckds, ckde,    &
3710                                cims, cime, cjms, cjme, ckms, ckme,    &
3711                                cips, cipe, cjps, cjpe, ckps, ckpe    )
3712
3713      CALL get_ijk_from_grid (  intermediate_grid ,              &
3714                                nids, nide, njds, njde, nkds, nkde,    &
3715                                nims, nime, njms, njme, nkms, nkme,    &
3716                                nips, nipe, njps, njpe, nkps, nkpe    )
3717
3718      nlev  = ckde - ckds + 1
3719
3720#include "nest_forcedown_pack.inc"
3721
3722!   WRITE(0,*)'I have completed PACKING of BCs data successfully'
3723
3724!#define COPY_OUT
3725!#include <scalar_derefs.inc>
3726      RETURN
3727   END SUBROUTINE force_domain_nmm_part1
3728
3729!==============================================================================================
3730
3731   SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags    &
3732!
3733#include "dummy_new_args.inc"
3734!
3735                 )
3736      USE module_state_description
3737      USE module_domain, ONLY : domain, get_ijk_from_grid
3738      USE module_configure, ONLY : grid_config_rec_type
3739      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
3740                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
3741      USE module_comm_dm, ONLY : HALO_NMM_FORCE_DOWN1_sub
3742      IMPLICIT NONE
3743!
3744      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
3745      TYPE(domain), POINTER :: ngrid
3746#include <dummy_new_decl.inc>
3747      INTEGER nlev, msize
3748      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3749      TYPE (grid_config_rec_type)            :: config_flags
3750      REAL xv(500)
3751      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
3752                                cims, cime, cjms, cjme, ckms, ckme,    &
3753                                cips, cipe, cjps, cjpe, ckps, ckpe
3754      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
3755                                nims, nime, njms, njme, nkms, nkme,    &
3756                                nips, nipe, njps, njpe, nkps, nkpe
3757      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
3758                                ims, ime, jms, jme, kms, kme,    &
3759                                ips, ipe, jps, jpe, kps, kpe
3760
3761      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
3762      REAL  dummy_xs, dummy_xe, dummy_ys, dummy_ye
3763
3764integer myproc
3765
3766!#ifdef DEREF_KLUDGE
3767!!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
3768!   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
3769!   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
3770!   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
3771!#endif
3772#include "deref_kludge.h"
3773
3774!#define COPY_IN
3775!#include <scalar_derefs.inc>
3776
3777      CALL get_ijk_from_grid (  grid ,                   &
3778                                cids, cide, cjds, cjde, ckds, ckde,    &
3779                                cims, cime, cjms, cjme, ckms, ckme,    &
3780                                cips, cipe, cjps, cjpe, ckps, ckpe    )
3781      CALL get_ijk_from_grid (  ngrid ,              &
3782                                nids, nide, njds, njde, nkds, nkde,    &
3783                                nims, nime, njms, njme, nkms, nkme,    &
3784                                nips, nipe, njps, njpe, nkps, nkpe    )
3785
3786      nlev  = ckde - ckds + 1
3787
3788#include "nest_interpdown_unpack.inc"
3789
3790      CALL get_ijk_from_grid (  grid ,              &
3791                                ids, ide, jds, jde, kds, kde,    &
3792                                ims, ime, jms, jme, kms, kme,    &
3793                                ips, ipe, jps, jpe, kps, kpe    )
3794
3795#include "HALO_NMM_FORCE_DOWN1.inc"
3796
3797      ! code here to interpolate the data into the nested domain
3798#include "nest_forcedown_interp.inc"
3799
3800!#define COPY_OUT
3801!#include <scalar_derefs.inc>
3802
3803      RETURN
3804   END SUBROUTINE force_domain_nmm_part2
3805
3806!================================================================================
3807!
3808! This routine exists only to call a halo on a domain (the nest)
3809! gets called from feedback_domain_em_part1, below.  This is needed
3810! because the halo code expects the fields being exchanged to have
3811! been dereferenced from the grid data structure, but in feedback_domain_em_part1
3812! the grid data structure points to the coarse domain, not the nest.
3813! And we want the halo exchange on the nest, so that the code in
3814! em_nest_feedbackup_interp.inc will work correctly on multi-p. JM 20040308
3815!
3816
3817   SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags    &
3818!
3819#include "dummy_new_args.inc"
3820!
3821)
3822      USE module_state_description
3823      USE module_domain, ONLY : domain, get_ijk_from_grid
3824      USE module_configure, ONLY : grid_config_rec_type
3825      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
3826                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
3827      USE module_comm_dm, ONLY : HALO_NMM_WEIGHTS_sub
3828      IMPLICIT NONE
3829!
3830      TYPE(domain), TARGET :: grid          ! name of the grid being dereferenced (must be "grid")
3831      TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of
3832                                                  ! soil temp, moisture, etc., has vertical dim
3833                                                  ! of soil categories
3834#include <dummy_new_decl.inc>
3835
3836      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
3837                                ims, ime, jms, jme, kms, kme,    &
3838                                ips, ipe, jps, jpe, kps, kpe
3839
3840      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
3841
3842      INTEGER       :: idum1, idum2
3843
3844
3845!#ifdef DEREF_KLUDGE
3846!!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
3847!   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
3848!   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
3849!   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
3850!#endif
3851#include "deref_kludge.h"
3852
3853!#define COPY_IN
3854!#include <scalar_derefs.inc>
3855
3856      CALL get_ijk_from_grid (  grid ,              &
3857                                ids, ide, jds, jde, kds, kde,    &
3858                                ims, ime, jms, jme, kms, kme,    &
3859                                ips, ipe, jps, jpe, kps, kpe    )
3860
3861#ifdef DM_PARALLEL
3862#include "HALO_NMM_WEIGHTS.inc"
3863#endif
3864
3865!#define COPY_OUT
3866!#include <scalar_derefs.inc>
3867
3868   END SUBROUTINE feedback_nest_prep_nmm
3869
3870!------------------------------------------------------------------
3871
3872   SUBROUTINE feedback_domain_nmm_part1 ( grid, ngrid, config_flags    &
3873!
3874#include "dummy_new_args.inc"
3875!
3876                 )
3877      USE module_state_description
3878      USE module_domain, ONLY : domain, get_ijk_from_grid
3879      USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec
3880      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
3881                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
3882      IMPLICIT NONE
3883!
3884      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
3885      TYPE(domain), POINTER :: ngrid
3886#include <dummy_new_decl.inc>
3887      INTEGER nlev, msize
3888      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
3889      TYPE(domain), POINTER :: xgrid
3890      TYPE (grid_config_rec_type)            :: config_flags, nconfig_flags
3891      REAL xv(500)
3892      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
3893                                cims, cime, cjms, cjme, ckms, ckme,    &
3894                                cips, cipe, cjps, cjpe, ckps, ckpe
3895      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
3896                                nims, nime, njms, njme, nkms, nkme,    &
3897                                nips, nipe, njps, njpe, nkps, nkpe
3898
3899      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
3900
3901      INTEGER local_comm, myproc, nproc, idum1, idum2
3902
3903!#ifdef DEREF_KLUDGE
3904!!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
3905!   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
3906!   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
3907!   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
3908!#endif
3909
3910      INTERFACE
3911          SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags    &
3912!
3913#include "dummy_new_args.inc"
3914!
3915)
3916             USE module_state_description
3917             USE module_domain, ONLY : domain
3918             USE module_configure, ONLY : grid_config_rec_type
3919!
3920             TYPE (grid_config_rec_type)            :: config_flags
3921             TYPE(domain), TARGET                   :: grid
3922#include <dummy_new_decl.inc>
3923          END SUBROUTINE feedback_nest_prep_nmm
3924      END INTERFACE
3925!
3926!#define COPY_IN
3927!#include <scalar_derefs.inc>
3928
3929      CALL wrf_get_dm_communicator ( local_comm )
3930      CALL wrf_get_myproc( myproc )
3931      CALL wrf_get_nproc( nproc )
3932
3933
3934!
3935! intermediate grid
3936      CALL get_ijk_from_grid (  grid ,                   &
3937                                cids, cide, cjds, cjde, ckds, ckde,    &
3938                                cims, cime, cjms, cjme, ckms, ckme,    &
3939                                cips, cipe, cjps, cjpe, ckps, ckpe    )
3940! nest grid
3941      CALL get_ijk_from_grid (  ngrid ,                  &
3942                                nids, nide, njds, njde, nkds, nkde,    &
3943                                nims, nime, njms, njme, nkms, nkme,    &
3944                                nips, nipe, njps, njpe, nkps, nkpe    )
3945
3946      nlev  = ckde - ckds + 1
3947
3948      ips_save = ngrid%i_parent_start  ! +1 not used in ipe_save & jpe_save
3949      jps_save = ngrid%j_parent_start  !  because of one extra namelist point
3950      ipe_save = ngrid%i_parent_start + (nide-nids) / ngrid%parent_grid_ratio
3951      jpe_save = ngrid%j_parent_start + (njde-njds) / ngrid%parent_grid_ratio
3952
3953! feedback_nest_prep invokes a halo exchange on the ngrid. It is done this way
3954! in a separate routine because the HALOs need the data to be dereference from the
3955! grid data structure and, in this routine, the dereferenced fields are related to
3956! the intermediate domain, not the nest itself. Save the current grid pointer to intermediate
3957! domain, switch grid to point to ngrid, invoke feedback_nest_prep,  then restore grid
3958! to point to intermediate domain.
3959
3960      CALL model_to_grid_config_rec ( ngrid%id , model_config_rec , nconfig_flags )
3961      CALL set_scalar_indices_from_config ( ngrid%id , idum1 , idum2 )
3962      xgrid => grid
3963      grid => ngrid
3964#include "deref_kludge.h"
3965      CALL feedback_nest_prep_nmm ( grid, config_flags    &
3966!
3967#include "actual_new_args.inc"
3968!
3969)
3970
3971! put things back so grid is intermediate grid
3972
3973      grid => xgrid
3974      CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
3975
3976! "interp" (basically copy) ngrid onto intermediate grid
3977
3978#include "nest_feedbackup_interp.inc"
3979
3980!#define COPY_OUT
3981!#include <scalar_derefs.inc>
3982      RETURN
3983   END SUBROUTINE feedback_domain_nmm_part1
3984
3985!------------------------------------------------------------------
3986
3987   SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_flags    &
3988!
3989#include "dummy_new_args.inc"
3990!
3991                 )
3992      USE module_state_description
3993      USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid
3994      USE module_configure, ONLY : grid_config_rec_type
3995      USE module_dm, ONLY : get_dm_max_halo_width, ips_save, ipe_save, &
3996                            jps_save, jpe_save, ntasks, mytask, ntasks_x, ntasks_y, &
3997                            local_communicator, itrace
3998      USE module_comm_nesting_dm, ONLY : halo_interp_up_sub
3999      USE module_utility
4000      IMPLICIT NONE
4001
4002!
4003      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
4004      TYPE(domain), POINTER :: intermediate_grid
4005      TYPE(domain), POINTER :: ngrid
4006
4007#include <dummy_new_decl.inc>
4008      INTEGER nlev, msize
4009      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
4010      TYPE (grid_config_rec_type)            :: config_flags
4011      REAL xv(500)
4012      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
4013                                cims, cime, cjms, cjme, ckms, ckme,    &
4014                                cips, cipe, cjps, cjpe, ckps, ckpe
4015      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
4016                                nims, nime, njms, njme, nkms, nkme,    &
4017                                nips, nipe, njps, njpe, nkps, nkpe
4018      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
4019                                ims, ime, jms, jme, kms, kme,    &
4020                                ips, ipe, jps, jpe, kps, kpe
4021
4022      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
4023
4024      INTEGER icoord, jcoord, idim_cd, jdim_cd
4025      INTEGER local_comm, myproc, nproc
4026      INTEGER iparstrt, jparstrt, sw
4027      INTEGER thisdomain_max_halo_width
4028
4029      character*256 :: timestr
4030      integer ierr
4031
4032      REAL    nest_influence
4033      LOGICAL, EXTERNAL  :: cd_feedback_mask
4034      LOGICAL, EXTERNAL  :: cd_feedback_mask_v
4035
4036!#define COPY_IN
4037!#include <scalar_derefs.inc>
4038
4039! On entry to this routine,
4040!  "grid" refers to the parent domain
4041!  "intermediate_grid" refers to local copy of parent domain that overlies this patch of nest
4042!  "ngrid" refers to the nest, which is only needed for smoothing on the parent because
4043!          the nest feedback data has already been transferred during em_nest_feedbackup_interp
4044!          in part1, above.
4045! The way these settings c and n dimensions are set, below, looks backwards but from the point
4046! of view of the RSL routine rsl_lite_to_parent_info(), call to which is included by
4047! em_nest_feedbackup_pack, the "n" domain represents the parent domain and the "c" domain
4048! represents the intermediate domain. The backwards lookingness should be fixed in the gen_comms.c
4049! registry routine that accompanies RSL_LITE but, just as it's sometimes easier to put up a road
4050! sign that says "DIP" than fix the dip,  at this point it was easier just to write this comment. JM
4051!
4052
4053      nest_influence = 0.5
4054#define NEST_INFLUENCE(A,B) A = nest_influence*(B) + (1.0-nest_influence)*(A)
4055
4056
4057      CALL domain_clock_get( grid, current_timestr=timestr )
4058
4059      CALL get_ijk_from_grid (  intermediate_grid ,                   &
4060                                cids, cide, cjds, cjde, ckds, ckde,    &
4061                                cims, cime, cjms, cjme, ckms, ckme,    &
4062                                cips, cipe, cjps, cjpe, ckps, ckpe    )
4063      CALL get_ijk_from_grid (  grid ,              &
4064                                nids, nide, njds, njde, nkds, nkde,    &
4065                                nims, nime, njms, njme, nkms, nkme,    &
4066                                nips, nipe, njps, njpe, nkps, nkpe    )
4067
4068      nide = nide - 1   !dusan
4069      njde = njde - 1   !dusan
4070
4071      CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
4072      CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
4073      CALL nl_get_shw            ( intermediate_grid%id, sw )
4074      icoord =    iparstrt  - sw
4075      jcoord =    jparstrt  - sw
4076      idim_cd = cide - cids + 1
4077      jdim_cd = cjde - cjds + 1
4078
4079      nlev  = ckde - ckds + 1
4080
4081      CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width )
4082#include "nest_feedbackup_pack.inc"
4083
4084      CALL wrf_get_dm_communicator ( local_comm )
4085      CALL wrf_get_myproc( myproc )
4086      CALL wrf_get_nproc( nproc )
4087
4088      CALL rsl_lite_merge_msgs( myproc, nproc, local_comm )
4089
4090#include "nest_feedbackup_unpack.inc"
4091
4092
4093      ! smooth coarse grid
4094
4095      CALL get_ijk_from_grid (  ngrid,                                 &
4096                                nids, nide, njds, njde, nkds, nkde,    &
4097                                nims, nime, njms, njme, nkms, nkme,    &
4098                                nips, nipe, njps, njpe, nkps, nkpe     )
4099      CALL get_ijk_from_grid (  grid ,              &
4100                                ids, ide, jds, jde, kds, kde,    &
4101                                ims, ime, jms, jme, kms, kme,    &
4102                                ips, ipe, jps, jpe, kps, kpe    )
4103
4104#include "HALO_INTERP_UP.inc"
4105
4106      CALL get_ijk_from_grid (  grid ,                   &
4107                                cids, cide, cjds, cjde, ckds, ckde,    &
4108                                cims, cime, cjms, cjme, ckms, ckme,    &
4109                                cips, cipe, cjps, cjpe, ckps, ckpe    )
4110
4111#include "nest_feedbackup_smooth.inc"
4112
4113!#define COPY_OUT
4114!#include <scalar_derefs.inc>
4115      RETURN
4116   END SUBROUTINE feedback_domain_nmm_part2
4117
4118!=================================================================================
4119!   End of gopal's doing
4120!=================================================================================
4121#endif
4122
4123!------------------------------------------------------------------
4124
4125   SUBROUTINE wrf_gatherv_real (Field, field_ofst,            &
4126                                my_count ,                    &    ! sendcount
4127                                globbuf, glob_ofst ,          &    ! recvbuf
4128                                counts                      , &    ! recvcounts
4129                                displs                      , &    ! displs
4130                                root                        , &    ! root
4131                                communicator                , &    ! communicator
4132                                ierr )
4133   USE module_dm, ONLY : getrealmpitype
4134   IMPLICIT NONE
4135   INTEGER field_ofst, glob_ofst
4136   INTEGER my_count, communicator, root, ierr
4137   INTEGER , DIMENSION(*) :: counts, displs
4138   REAL, DIMENSION(*) :: Field, globbuf
4139#ifndef STUBMPI
4140   INCLUDE 'mpif.h'
4141
4142           CALL mpi_gatherv( Field( field_ofst ),      &    ! sendbuf
4143                            my_count ,                       &    ! sendcount
4144                            getrealmpitype() ,               &    ! sendtype
4145                            globbuf( glob_ofst ) ,                 &    ! recvbuf
4146                            counts                         , &    ! recvcounts
4147                            displs                         , &    ! displs
4148                            getrealmpitype()               , &    ! recvtype
4149                            root                           , &    ! root
4150                            communicator                   , &    ! communicator
4151                            ierr )
4152#endif
4153
4154   END SUBROUTINE wrf_gatherv_real
4155
4156   SUBROUTINE wrf_gatherv_double (Field, field_ofst,            &
4157                                my_count ,                    &    ! sendcount
4158                                globbuf, glob_ofst ,          &    ! recvbuf
4159                                counts                      , &    ! recvcounts
4160                                displs                      , &    ! displs
4161                                root                        , &    ! root
4162                                communicator                , &    ! communicator
4163                                ierr )
4164!   USE module_dm
4165   IMPLICIT NONE
4166   INTEGER field_ofst, glob_ofst
4167   INTEGER my_count, communicator, root, ierr
4168   INTEGER , DIMENSION(*) :: counts, displs
4169! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
4170! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
4171! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
4172! if we were not indexing the globbuf and Field arrays it would not even matter
4173   REAL, DIMENSION(*) :: Field, globbuf
4174#ifndef STUBMPI
4175   INCLUDE 'mpif.h'
4176
4177           CALL mpi_gatherv( Field( field_ofst ),      &    ! sendbuf
4178                            my_count ,                       &    ! sendcount
4179                            MPI_DOUBLE_PRECISION         ,               &    ! sendtype
4180                            globbuf( glob_ofst ) ,                 &    ! recvbuf
4181                            counts                         , &    ! recvcounts
4182                            displs                         , &    ! displs
4183                            MPI_DOUBLE_PRECISION                       , &    ! recvtype
4184                            root                           , &    ! root
4185                            communicator                   , &    ! communicator
4186                            ierr )
4187#endif
4188
4189   END SUBROUTINE wrf_gatherv_double
4190
4191   SUBROUTINE wrf_gatherv_integer (Field, field_ofst,            &
4192                                my_count ,                    &    ! sendcount
4193                                globbuf, glob_ofst ,          &    ! recvbuf
4194                                counts                      , &    ! recvcounts
4195                                displs                      , &    ! displs
4196                                root                        , &    ! root
4197                                communicator                , &    ! communicator
4198                                ierr )
4199   IMPLICIT NONE
4200   INTEGER field_ofst, glob_ofst
4201   INTEGER my_count, communicator, root, ierr
4202   INTEGER , DIMENSION(*) :: counts, displs
4203   INTEGER, DIMENSION(*) :: Field, globbuf
4204#ifndef STUBMPI
4205   INCLUDE 'mpif.h'
4206
4207           CALL mpi_gatherv( Field( field_ofst ),      &    ! sendbuf
4208                            my_count ,                       &    ! sendcount
4209                            MPI_INTEGER         ,               &    ! sendtype
4210                            globbuf( glob_ofst ) ,                 &    ! recvbuf
4211                            counts                         , &    ! recvcounts
4212                            displs                         , &    ! displs
4213                            MPI_INTEGER                       , &    ! recvtype
4214                            root                           , &    ! root
4215                            communicator                   , &    ! communicator
4216                            ierr )
4217#endif
4218
4219   END SUBROUTINE wrf_gatherv_integer
4220
4221!new stuff 20070124
4222   SUBROUTINE wrf_scatterv_real (                             &
4223                                globbuf, glob_ofst ,          &    ! recvbuf
4224                                counts                      , &    ! recvcounts
4225                                Field, field_ofst,            &
4226                                my_count ,                    &    ! sendcount
4227                                displs                      , &    ! displs
4228                                root                        , &    ! root
4229                                communicator                , &    ! communicator
4230                                ierr )
4231   USE module_dm, ONLY : getrealmpitype
4232   IMPLICIT NONE
4233   INTEGER field_ofst, glob_ofst
4234   INTEGER my_count, communicator, root, ierr
4235   INTEGER , DIMENSION(*) :: counts, displs
4236   REAL, DIMENSION(*) :: Field, globbuf
4237#ifndef STUBMPI
4238   INCLUDE 'mpif.h'
4239
4240           CALL mpi_scatterv(                                &
4241                            globbuf( glob_ofst ) ,           &    ! recvbuf
4242                            counts                         , &    ! recvcounts
4243                            displs                         , &    ! displs
4244                            getrealmpitype()               , &    ! recvtype
4245                            Field( field_ofst ),             &    ! sendbuf
4246                            my_count ,                       &    ! sendcount
4247                            getrealmpitype() ,               &    ! sendtype
4248                            root                           , &    ! root
4249                            communicator                   , &    ! communicator
4250                            ierr )
4251#endif
4252
4253   END SUBROUTINE wrf_scatterv_real
4254
4255   SUBROUTINE wrf_scatterv_double (                           &
4256                                globbuf, glob_ofst ,          &    ! recvbuf
4257                                counts                      , &    ! recvcounts
4258                                Field, field_ofst,            &
4259                                my_count ,                    &    ! sendcount
4260                                displs                      , &    ! displs
4261                                root                        , &    ! root
4262                                communicator                , &    ! communicator
4263                                ierr )
4264   IMPLICIT NONE
4265   INTEGER field_ofst, glob_ofst
4266   INTEGER my_count, communicator, root, ierr
4267   INTEGER , DIMENSION(*) :: counts, displs
4268   REAL, DIMENSION(*) :: Field, globbuf
4269#ifndef STUBMPI
4270   INCLUDE 'mpif.h'
4271! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
4272! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
4273! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
4274! if we were not indexing the globbuf and Field arrays it would not even matter
4275
4276           CALL mpi_scatterv(                                &
4277                            globbuf( glob_ofst ) ,           &    ! recvbuf
4278                            counts                         , &    ! recvcounts
4279                            displs                         , &    ! displs
4280                            MPI_DOUBLE_PRECISION           , &    ! recvtype
4281                            Field( field_ofst ),             &    ! sendbuf
4282                            my_count ,                       &    ! sendcount
4283                            MPI_DOUBLE_PRECISION         ,   &    ! sendtype
4284                            root                           , &    ! root
4285                            communicator                   , &    ! communicator
4286                            ierr )
4287#endif
4288
4289   END SUBROUTINE wrf_scatterv_double
4290
4291   SUBROUTINE wrf_scatterv_integer (                          &
4292                                globbuf, glob_ofst ,          &    ! recvbuf
4293                                counts                      , &    ! recvcounts
4294                                Field, field_ofst,            &
4295                                my_count ,                    &    ! sendcount
4296                                displs                      , &    ! displs
4297                                root                        , &    ! root
4298                                communicator                , &    ! communicator
4299                                ierr )
4300   IMPLICIT NONE
4301   INTEGER field_ofst, glob_ofst
4302   INTEGER my_count, communicator, root, ierr
4303   INTEGER , DIMENSION(*) :: counts, displs
4304   INTEGER, DIMENSION(*) :: Field, globbuf
4305#ifndef STUBMPI
4306   INCLUDE 'mpif.h'
4307
4308           CALL mpi_scatterv(                                &
4309                            globbuf( glob_ofst ) ,           &    ! recvbuf
4310                            counts                         , &    ! recvcounts
4311                            displs                         , &    ! displs
4312                            MPI_INTEGER                    , &    ! recvtype
4313                            Field( field_ofst ),             &    ! sendbuf
4314                            my_count ,                       &    ! sendcount
4315                            MPI_INTEGER         ,            &    ! sendtype
4316                            root                           , &    ! root
4317                            communicator                   , &    ! communicator
4318                            ierr )
4319#endif
4320
4321   END SUBROUTINE wrf_scatterv_integer
4322! end new stuff 20070124
4323
4324     SUBROUTINE wrf_dm_gatherv ( v, elemsize , km_s, km_e, wordsz )
4325      IMPLICIT NONE
4326      INTEGER  elemsize, km_s, km_e, wordsz
4327      REAL v(*)
4328      IF ( wordsz .EQ. DWORDSIZE ) THEN
4329         CALL wrf_dm_gatherv_double(v, elemsize , km_s, km_e)
4330      ELSE
4331         CALL wrf_dm_gatherv_single(v, elemsize , km_s, km_e)
4332      ENDIF
4333     END SUBROUTINE wrf_dm_gatherv
4334
4335     SUBROUTINE wrf_dm_gatherv_double ( v, elemsize , km_s, km_e )
4336      IMPLICIT NONE
4337      INTEGER  elemsize, km_s, km_e
4338      REAL*8 v(0:*)
4339#ifndef STUBMPI
4340# ifndef USE_MPI_IN_PLACE
4341      REAL*8 v_local((km_e-km_s+1)*elemsize)
4342# endif
4343      INTEGER, DIMENSION(:), ALLOCATABLE :: recvcounts, displs
4344      INTEGER send_type, myproc, nproc, local_comm, ierr, i
4345   INCLUDE 'mpif.h'
4346      send_type = MPI_DOUBLE_PRECISION
4347      CALL wrf_get_dm_communicator ( local_comm )
4348      CALL wrf_get_nproc( nproc )
4349      CALL wrf_get_myproc( myproc )
4350      ALLOCATE( recvcounts(nproc), displs(nproc) )
4351      i = (km_e-km_s+1)*elemsize
4352      CALL mpi_allgather( i,1,MPI_INTEGER,recvcounts,1,MPI_INTEGER,local_comm,ierr) ;
4353      i = (km_s)*elemsize
4354      CALL mpi_allgather( i,1,MPI_INTEGER,displs,1,MPI_INTEGER,local_comm,ierr) ;
4355#  ifdef USE_MPI_IN_PLACE
4356      CALL mpi_allgatherv( MPI_IN_PLACE,                                  &
4357#  else
4358      DO i = 1,elemsize*(km_e-km_s+1)
4359        v_local(i) = v(i+km_s-1)
4360      ENDDO
4361      CALL mpi_allgatherv( v_local,                                       &
4362#  endif
4363                           (km_e-km_s+1)*elemsize,                        &
4364                           send_type,                                     &
4365                           v,                                             &
4366                           recvcounts,                                    &
4367                           displs,                                        &
4368                           send_type,                                     &
4369                           local_comm,                                    &
4370                           ierr )
4371      DEALLOCATE(recvcounts)
4372      DEALLOCATE(displs)
4373#endif
4374      return
4375     END SUBROUTINE wrf_dm_gatherv_double
4376
4377     SUBROUTINE wrf_dm_gatherv_single ( v, elemsize , km_s, km_e )
4378      IMPLICIT NONE
4379      INTEGER  elemsize, km_s, km_e
4380      REAL*4 v(0:*)
4381#ifndef STUBMPI
4382# ifndef USE_MPI_IN_PLACE
4383      REAL*4 v_local((km_e-km_s+1)*elemsize)
4384# endif
4385      INTEGER, DIMENSION(:), ALLOCATABLE :: recvcounts, displs
4386      INTEGER send_type, myproc, nproc, local_comm, ierr, i
4387   INCLUDE 'mpif.h'
4388      send_type = MPI_REAL
4389      CALL wrf_get_dm_communicator ( local_comm )
4390      CALL wrf_get_nproc( nproc )
4391      CALL wrf_get_myproc( myproc )
4392      ALLOCATE( recvcounts(nproc), displs(nproc) )
4393      i = (km_e-km_s+1)*elemsize
4394      CALL mpi_allgather( i,1,MPI_INTEGER,recvcounts,1,MPI_INTEGER,local_comm,ierr) ;
4395      i = (km_s)*elemsize
4396      CALL mpi_allgather( i,1,MPI_INTEGER,displs,1,MPI_INTEGER,local_comm,ierr) ;
4397#  ifdef USE_MPI_IN_PLACE
4398      CALL mpi_allgatherv( MPI_IN_PLACE,                                  &
4399#  else
4400      DO i = 1,elemsize*(km_e-km_s+1)
4401        v_local(i) = v(i+km_s-1)
4402      ENDDO
4403      CALL mpi_allgatherv( v_local,                                       &
4404#  endif
4405                           (km_e-km_s+1)*elemsize,                        &
4406                           send_type,                                     &
4407                           v,                                             &
4408                           recvcounts,                                    &
4409                           displs,                                        &
4410                           send_type,                                     &
4411                           local_comm,                                    &
4412                           ierr )
4413      DEALLOCATE(recvcounts)
4414      DEALLOCATE(displs)
4415#endif
4416      return
4417     END SUBROUTINE wrf_dm_gatherv_single
4418
4419      SUBROUTINE wrf_dm_decomp1d( nt, km_s, km_e )
4420       IMPLICIT NONE
4421       INTEGER, INTENT(IN)  :: nt
4422       INTEGER, INTENT(OUT) :: km_s, km_e
4423     ! local
4424       INTEGER nn, nnp,  na, nb
4425       INTEGER myproc, nproc
4426
4427       CALL wrf_get_myproc(myproc)
4428       CALL wrf_get_nproc(nproc)
4429       nn = nt / nproc           ! min number done by this task
4430       nnp = nn
4431       if ( myproc .lt. mod( nt, nproc ) )   nnp = nnp + 1 ! distribute remainder
4432
4433       na = min( myproc, mod(nt,nproc) ) ! Number of blocks with remainder that precede this one
4434       nb = max( 0, myproc - na )        ! number of blocks without a remainder that precede this one
4435       km_s = na * ( nn+1) + nb * nn     ! starting iteration for this task
4436       km_e = km_s + nnp - 1             ! ending iteration for this task
4437      END SUBROUTINE wrf_dm_decomp1d
4438
4439
4440SUBROUTINE wrf_dm_define_comms ( grid )
4441   USE module_domain, ONLY : domain
4442   IMPLICIT NONE
4443   TYPE(domain) , INTENT (INOUT) :: grid
4444   RETURN
4445END SUBROUTINE wrf_dm_define_comms
4446
4447SUBROUTINE tfp_message( fname, lno )
4448   CHARACTER*(*) fname
4449   INTEGER lno
4450   CHARACTER*1024 mess
4451#ifndef STUBMPI
4452   WRITE(mess,*)'tfp_message: ',trim(fname),lno
4453   CALL wrf_message(mess)
4454# ifdef ALLOW_OVERDECOMP
4455     CALL task_for_point_message  ! defined in RSL_LITE/task_for_point.c
4456# else
4457     CALL wrf_error_fatal(mess)
4458# endif
4459#endif
4460END SUBROUTINE tfp_message
4461
4462   SUBROUTINE set_dm_debug
4463    USE module_dm, ONLY : dm_debug_flag
4464    IMPLICIT NONE
4465    dm_debug_flag = .TRUE.
4466   END SUBROUTINE set_dm_debug
4467   SUBROUTINE reset_dm_debug
4468    USE module_dm, ONLY : dm_debug_flag
4469    IMPLICIT NONE
4470    dm_debug_flag = .FALSE.
4471   END SUBROUTINE reset_dm_debug
4472   SUBROUTINE get_dm_debug ( arg )
4473    USE module_dm, ONLY : dm_debug_flag
4474    IMPLICIT NONE
4475    LOGICAL arg
4476    arg = dm_debug_flag
4477   END SUBROUTINE get_dm_debug
4478
Note: See TracBrowser for help on using the repository browser.