FV3 Bundle
mpp_io_unstructured_write.inc
Go to the documentation of this file.
1 !***********************************************************************
2 !* GNU Lesser General Public License
3 !*
4 !* This file is part of the GFDL Flexible Modeling System (FMS).
5 !*
6 !* FMS is free software: you can redistribute it and/or modify it under
7 !* the terms of the GNU Lesser General Public License as published by
8 !* the Free Software Foundation, either version 3 of the License, or (at
9 !* your option) any later version.
10 !*
11 !* FMS is distributed in the hope that it will be useful, but WITHOUT
12 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
14 !* for more details.
15 !*
16 !* You should have received a copy of the GNU Lesser General Public
17 !* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
18 !***********************************************************************
19 
20 !----------
21 !ug support
22 
23 !------------------------------------------------------------------------------
24 !>Write data for a 1D field associated with an unstructured mpp domain to a
25 !!restart file.
26 subroutine mpp_io_unstructured_write_r_1D(funit, &
27  field, &
28  domain, &
29  fdata, &
30  nelems_io, &
31  tstamp, &
32  default_data)
33 
34  !Inputs/outputs
35  integer(INT_KIND),intent(in) :: funit !<A file unit for the to which the data will be written.
36  type(fieldtype),intent(inout) :: field !<A field whose data will be written.
37  type(domainUG),intent(inout) :: domain !<An unstructured mpp domain associatd with the inputted file.
38  real,dimension(:),intent(inout) :: fdata !<The data that will be written to the file.
39  integer,dimension(:),intent(in) :: nelems_io !<Number of grid points in the compressed dimension for each rank (correct
40  !!sizes only exist for the root rank of I/O domain pelist.)
41  real,intent(in),optional :: tstamp !<A time value.
42  real,intent(in), optional :: default_data !<Fill value for the inputted field.
43 
44  !Local variables
45  real :: fill !<Fill value for the inputted field. This defaults to zero.
46  type(domainUG),pointer :: io_domain !<Pointer to the unstructured I/O domain.
47  integer(INT_KIND) :: io_domain_npes !<The total number of ranks in an I/O domain pelist.
48  integer(INT_KIND),dimension(:),allocatable :: pelist !<A pelist.
49  integer(INT_KIND) :: nelems !<Total number of data points (sum(nelems_io)) to be written by the root rank of the pelist.
50  real,dimension(:),allocatable :: rbuff !<Buffer used to gather the data onto the root rank of the pelist.
51  real,dimension(:),allocatable :: cdata !<Array used to write the data to the file after the gather is performed.
52  integer(INT_KIND) :: i !<Loop variable.
53 
54  !Start the mpp timer.
55  !mpp_write_clock is a module variable.
56  call mpp_clock_begin(mpp_write_clock)
57 
58  !Make sure that the module is initialized.
59  if (.not. module_is_initialized) then
60  call mpp_error(FATAL, &
61  "mpp_io_unstructured_write_r_1D:" &
62  //" you must first call mpp_io_init.")
63  endif
64 
65  !Make sure that another NetCDF file is not currently using the inputted
66  !file unit.
67  if (.not. mpp_file(funit)%valid) then
68  call mpp_error(FATAL, &
69  "mpp_io_unstructured_write_r_1D:" &
70  //" the inputted file unit is already in use.")
71  endif
72 
73  !Set the fill value for the field.
74  fill = 0.0
75  if (present(default_data)) then
76  fill = default_data
77  endif
78 
79  !Point to the I/O domain associated with the inputted unstructured mpp
80  !domain.
81  io_domain => null()
82  io_domain => mpp_get_UG_io_domain(domain)
83 
84  !Get the pelist associated with the I/O domain.
85  io_domain_npes = mpp_get_UG_domain_npes(io_domain)
86  allocate(pelist(io_domain_npes))
87  call mpp_get_UG_domain_pelist(io_domain, &
88  pelist)
89 
90  !Make sure that only the root rank of the pelist will write to the file.
91  !This check is needed because data is only gathered on the lowest rank
92  !of the pelist.
93  if (mpp_pe() .eq. pelist(1) .and. .not. &
94  mpp_file(funit)%write_on_this_pe) then
95  call mpp_error(FATAL, &
96  "mpp_io_unstructured_write_r_1D:" &
97  //" the root rank of the pelist must be allowed" &
98  //" to perform the write.")
99  endif
100  if (mpp_pe() .ne. pelist(1) .and. mpp_file(funit)%write_on_this_pe) then
101  call mpp_error(FATAL, &
102  "mpp_io_unstructured_write_r_1D:" &
103  //" the non-root ranks of the pelist are not" &
104  //" allowed to perform the write.")
105  endif
106 
107  !Allocate an array which will be used to gather the data to be written
108  !onto the root rank of the pelist.
109  if (mpp_pe() .eq. pelist(1)) then
110  nelems = sum(nelems_io)
111  allocate(rbuff(nelems))
112  else
113  allocate(rbuff(1))
114  endif
115 
116  !Perform the gather of data onto the root rank (pelist(1)).
117  call mpp_gather(fdata, &
118  size(fdata), &
119  rbuff, &
120  nelems_io, &
121  pelist)
122 
123  !Write out the data to the file. This is only done by the root rank
124  !of the pelist.
125  if (mpp_pe() .eq. pelist(1)) then
126  allocate(cdata(nelems))
127  cdata = fill
128  do i = 1,nelems
129  cdata(i) = rbuff(i)
130  enddo
131  field%size(1) = nelems
132  call write_record_default(funit, &
133  field, &
134  nelems, &
135  cdata, &
136  tstamp)
137  deallocate(cdata)
138  endif
139 
140  !Deallocate local allocatables.
141  deallocate(rbuff)
142  deallocate(pelist)
143 
144  !Stop the mpp timer.
145  call mpp_clock_end(mpp_write_clock)
146 
147  return
148 end subroutine mpp_io_unstructured_write_r_1D
149 
150 !------------------------------------------------------------------------------
151 !>Write data for a 2D field associated with an unstructured mpp domain to a
152 !!restart file.
153 subroutine mpp_io_unstructured_write_r_2D(funit, &
154  field, &
155  domain, &
156  fdata, &
157  nelems_io, &
158  tstamp, &
159  default_data)
160 
161  !Inputs/outputs
162  integer(INT_KIND),intent(in) :: funit !<A file unit for the to which the data will be written.
163  type(fieldtype),intent(inout) :: field !<A field whose data will be written
164  type(domainUG),intent(inout) :: domain !<An unstructured mpp domain associatd with the inputted file.
165  real,dimension(:,:),intent(inout) :: fdata !<The data that will be written to the file.
166  integer,dimension(:),intent(in) :: nelems_io !<Number of grid points in the compressed dimension for each rank (correct
167  !!sizes only exist for the root rank of I/O domain pelist.)
168  real,intent(in),optional :: tstamp !<A time value.
169  real,intent(in), optional :: default_data !<Fill value for the inputted field.
170 
171  !Local variables
172  real :: fill !<Fill value for the inputted field. This defaults to zero.
173  type(domainUG),pointer :: io_domain !<Pointer to the unstructured I/O domain.
174  integer(INT_KIND) :: io_domain_npes !<The total number of ranks in an I/O domain pelist.
175  integer(INT_KIND),dimension(:),allocatable :: pelist !<A pelist.
176  integer(INT_KIND) :: dim_size_1 !<Number of data points in the first dimension (size(fdata,1)).
177  integer(INT_KIND) :: dim_size_2 !<Number of data points in the second dimension (size(fdata,2)).
178  real,dimension(:),allocatable :: sbuff !<Buffer used to gather the data onto the root rank of the pelist.
179  integer(INT_KIND) :: nelems !<Total number of unstructured data points (sum(nelems_io) for the root rank of the pelist).
180  real,dimension(:),allocatable :: rbuff !<Buffer used to gather the data onto the root rank of the pelist.
181  real,dimension(:,:),allocatable :: cdata !<Array used to write the data to the file after the gather is performed.
182  integer(INT_KIND) :: offset_r !<Offset for the rbuff array used to reorder the data before the netCDF write.
183  integer(INT_KIND) :: offset_c !<Offset for the cdata array used to reorder the data before the netCDF write.
184  integer(INT_KIND) :: i !<Loop variable.
185  integer(INT_KIND) :: j !<Loop variable.
186  integer(INT_KIND) :: k !<Loop variable.
187 
188  !Start the mpp timer.
189  !mpp_write_clock is a module variable.
190  call mpp_clock_begin(mpp_write_clock)
191 
192  !Make sure that the module is initialized.
193  if (.not. module_is_initialized) then
194  call mpp_error(FATAL, &
195  "mpp_io_unstructured_write_r_2D:" &
196  //" you must first call mpp_io_init.")
197  endif
198 
199  !Make sure that another NetCDF file is not currently using the inputted
200  !file unit.
201  if (.not. mpp_file(funit)%valid) then
202  call mpp_error(FATAL, &
203  "mpp_io_unstructured_write_r_2D:" &
204  //" the inputted file unit is already in use.")
205  endif
206 
207  !Set the fill value for the field.
208  fill = 0.0
209  if (present(default_data)) then
210  fill = default_data
211  endif
212 
213  !Point to the I/O domain associated with the inputted unstructured mpp
214  !domain.
215  io_domain => null()
216  io_domain => mpp_get_UG_io_domain(domain)
217 
218  !Get the pelist associated with the I/O domain.
219  io_domain_npes = mpp_get_UG_domain_npes(io_domain)
220  allocate(pelist(io_domain_npes))
221  call mpp_get_UG_domain_pelist(io_domain, &
222  pelist)
223 
224  !Make sure that only the root rank of the pelist will write to the file.
225  !This check is needed because data is only gathered on the lowest rank
226  !of the pelist.
227  if (mpp_pe() .eq. pelist(1) .and. .not. &
228  mpp_file(funit)%write_on_this_pe) then
229  call mpp_error(FATAL, &
230  "mpp_io_unstructured_write_r_2D:" &
231  //" the root rank of the pelist must be allowed" &
232  //" to perform the write.")
233  endif
234  if (mpp_pe() .ne. pelist(1) .and. mpp_file(funit)%write_on_this_pe) then
235  call mpp_error(FATAL, &
236  "mpp_io_unstructured_write_r_2D:" &
237  //" the non-root ranks of the pelist are not" &
238  //" allowed to perform the write.")
239  endif
240 
241  !Load the data elements for each rank into a one dimensional array, which
242  !will be used to gather the data onto the root rank of the pelist.
243  allocate(sbuff(size(fdata)))
244  dim_size_1 = size(fdata,1)
245  dim_size_2 = size(fdata,2)
246  do j = 1,dim_size_2
247  do i = 1,dim_size_1
248  sbuff((j-1)*dim_size_1+i) = fdata(i,j)
249  enddo
250  enddo
251 
252  !Allocate an array which will be used to gather the data to be written
253  !onto the root rank of the pelist.
254  if (mpp_pe() .eq. pelist(1)) then
255  nelems = sum(nelems_io)
256  allocate(rbuff(nelems*dim_size_2))
257  else
258  allocate(rbuff(1))
259  endif
260 
261  !Perform the gather of data onto the root rank (pelist(1)).
262  call mpp_gather(sbuff, &
263  size(sbuff), &
264  rbuff, &
265  nelems_io*dim_size_2, &
266  pelist)
267 
268  !Reorder the gather data so that is of the form (nelems,dim_size_2). Write
269  !out the data to the file. This is only done by the root rank of the
270  !pelist.
271  if (mpp_pe() .eq. pelist(1)) then
272  allocate(cdata(nelems,dim_size_2))
273  cdata = fill
274  do j = 1,dim_size_2
275  offset_c = 0
276  do k = 1,io_domain_npes
277  if (k .gt. 1) then
278  offset_r = (j-1)*nelems_io(k) + dim_size_2*(sum(nelems_io(1:k-1)))
279  else
280  offset_r = (j-1)*nelems_io(k)
281  endif
282  do i = 1,nelems_io(k)
283  cdata(i+offset_c,j) = rbuff(i+offset_r)
284  enddo
285  offset_c = offset_c + nelems_io(k)
286  enddo
287  enddo
288  field%size(1) = nelems
289  call write_record_default(funit, &
290  field, &
291  nelems*dim_size_2, &
292  cdata, &
293  tstamp)
294  deallocate(cdata)
295  endif
296 
297  !Deallocate local allocatables.
298  deallocate(sbuff)
299  deallocate(rbuff)
300  deallocate(pelist)
301 
302  !Stop the mpp timer.
303  call mpp_clock_end(mpp_write_clock)
304 
305  return
306 end subroutine mpp_io_unstructured_write_r_2D
307 
308 !------------------------------------------------------------------------------
309 !>Write data for a 3D field associated with an unstructured mpp domain to a
310 !!restart file.
311 subroutine mpp_io_unstructured_write_r_3D(funit, &
312  field, &
313  domain, &
314  fdata, &
315  nelems_io, &
316  tstamp, &
317  default_data)
318 
319  !Inputs/outputs
320  integer(INT_KIND),intent(in) :: funit !<A file unit for the to which the data will be written.
321  type(fieldtype),intent(inout) :: field !<A field whose data will be written
322  type(domainUG),intent(inout) :: domain !<An unstructured mpp domain associatd with the inputted file.
323  real,dimension(:,:,:),intent(inout) :: fdata !<The data that will be written to the file.
324  integer,dimension(:),intent(in) :: nelems_io !<Number of grid points in the compressed dimension for each rank (correct
325  !!sizes only exist for the root rank of I/O domain pelist.)
326  real,intent(in),optional :: tstamp !<A time value.
327  real,intent(in), optional :: default_data !<Fill value for the inputted field.
328 
329  !Local variables
330  real :: fill !<Fill value for the inputted field. This defaults to zero.
331  type(domainUG),pointer :: io_domain !<Pointer to the unstructured I/O domain.
332  integer(INT_KIND) :: io_domain_npes !<The total number of ranks in an I/O domain pelist.
333  integer(INT_KIND),dimension(:),allocatable :: pelist !<A pelist.
334  integer(INT_KIND) :: dim_size_1 !<Number of data points in the first dimension (size(fdata,1)).
335  integer(INT_KIND) :: dim_size_2 !<Number of data points in the second dimension (size(fdata,2)).
336  integer(INT_KIND) :: dim_size_3 !<Number of data points in the second dimension (size(fdata,3)).
337  real,dimension(:),allocatable :: sbuff !<Buffer used to gather the data onto the root rank of the pelist.
338  integer(INT_KIND) :: nelems !<Total number of unstructured data points (sum(nelems_io) for the root rank of the pelist).
339  real,dimension(:),allocatable :: rbuff !<Buffer used to gather the data onto the root rank of the pelist.
340  real,dimension(:,:,:),allocatable :: cdata !<Array used to write the data to the file after the gather is performed.
341  integer(INT_KIND) :: offset_r !<Offset for the rbuff array used to reorder the data before the netCDF write.
342  integer(INT_KIND) :: offset_c !<Offset for the cdata array used to reorder the data before the netCDF write.
343  integer(INT_KIND) :: i !<Loop variable.
344  integer(INT_KIND) :: j !<Loop variable.
345  integer(INT_KIND) :: k !<Loop variable.
346  integer(INT_KIND) :: m !<Loop variable.
347 
348  !Start the mpp timer.
349  !mpp_write_clock is a module variable.
350  call mpp_clock_begin(mpp_write_clock)
351 
352  !Make sure that the module is initialized.
353  if (.not. module_is_initialized) then
354  call mpp_error(FATAL, &
355  "mpp_io_unstructured_write_r_3D:" &
356  //" you must first call mpp_io_init.")
357  endif
358 
359  !Make sure that another NetCDF file is not currently using the inputted
360  !file unit.
361  if (.not. mpp_file(funit)%valid) then
362  call mpp_error(FATAL, &
363  "mpp_io_unstructured_write_r_3D:" &
364  //" the inputted file unit is already in use.")
365  endif
366 
367  !Set the fill value for the field.
368  fill = 0.0
369  if (present(default_data)) then
370  fill = default_data
371  endif
372 
373  !Point to the I/O domain associated with the inputted unstructured mpp
374  !domain.
375  io_domain => null()
376  io_domain => mpp_get_UG_io_domain(domain)
377 
378  !Get the pelist associated with the I/O domain.
379  io_domain_npes = mpp_get_UG_domain_npes(io_domain)
380  allocate(pelist(io_domain_npes))
381  call mpp_get_UG_domain_pelist(io_domain, &
382  pelist)
383 
384  !Make sure that only the root rank of the pelist will write to the file.
385  !This check is needed because data is only gathered on the lowest rank
386  !of the pelist.
387  if (mpp_pe() .eq. pelist(1) .and. .not. &
388  mpp_file(funit)%write_on_this_pe) then
389  call mpp_error(FATAL, &
390  "mpp_io_unstructured_write_r_3D:" &
391  //" the root rank of the pelist must be allowed" &
392  //" to perform the write.")
393  endif
394  if (mpp_pe() .ne. pelist(1) .and. mpp_file(funit)%write_on_this_pe) then
395  call mpp_error(FATAL, &
396  "mpp_io_unstructured_write_r_3D:" &
397  //" the non-root ranks of the pelist are not" &
398  //" allowed to perform the write.")
399  endif
400 
401  !Load the data elements for each rank into a one dimensional array, which
402  !will be used to gather the data onto the root rank of the pelist.
403  allocate(sbuff(size(fdata)))
404  dim_size_1 = size(fdata,1)
405  dim_size_2 = size(fdata,2)
406  dim_size_3 = size(fdata,3)
407  do k = 1,dim_size_3
408  do j = 1,dim_size_2
409  do i = 1,dim_size_1
410  sbuff((k-1)*dim_size_2*dim_size_1+(j-1)*dim_size_1+i) = fdata(i,j,k)
411  enddo
412  enddo
413  enddo
414 
415  !Allocate an array which will be used to gather the data to be written
416  !onto the root rank of the pelist.
417  if (mpp_pe() .eq. pelist(1)) then
418  nelems = sum(nelems_io)
419  allocate(rbuff(nelems*dim_size_2*dim_size_3))
420  else
421  allocate(rbuff(1))
422  endif
423 
424  !Perform the gather of data onto the root rank (pelist(1)).
425  call mpp_gather(sbuff, &
426  size(sbuff), &
427  rbuff, &
428  nelems_io*dim_size_2*dim_size_3, &
429  pelist)
430 
431  !Reorder the gather data so that is of the form (nelems,dim_size_2). Write
432  !out the data to the file. This is only done by the root rank of the
433  !pelist.
434  if (mpp_pe() .eq. pelist(1)) then
435  allocate(cdata(nelems,dim_size_2,dim_size_3))
436  cdata = fill
437  do m = 1,dim_size_3
438  do j = 1,dim_size_2
439  offset_c = 0
440  do k = 1,io_domain_npes
441  if (k .gt. 1) then
442  offset_r = (m-1)*dim_size_2*nelems_io(k) + &
443  (j-1)*nelems_io(k) + &
444  dim_size_2*dim_size_3*(sum(nelems_io(1:k-1)))
445  else
446  offset_r = (m-1)*dim_size_2*nelems_io(k) + &
447  (j-1)*nelems_io(k)
448  endif
449  do i = 1,nelems_io(k)
450  cdata(i+offset_c,j,m) = rbuff(i+offset_r)
451  enddo
452  offset_c = offset_c + nelems_io(k)
453  enddo
454  enddo
455  enddo
456  field%size(1) = nelems
457  call write_record_default(funit, &
458  field, &
459  nelems*dim_size_2*dim_size_3, &
460  cdata, &
461  tstamp)
462  deallocate(cdata)
463  endif
464 
465  !Deallocate local allocatables.
466  deallocate(sbuff)
467  deallocate(rbuff)
468  deallocate(pelist)
469 
470  !Stop the mpp timer.
471  call mpp_clock_end(mpp_write_clock)
472 
473  return
474 end subroutine mpp_io_unstructured_write_r_3D
475 
476 !------------------------------------------------------------------------------
477 !>Write data for a 4D field associated with an unstructured mpp domain to a
478 !!restart file.
479 subroutine mpp_io_unstructured_write_r_4D(funit, &
480  field, &
481  domain, &
482  fdata, &
483  nelems_io_in, &
484  tstamp, &
485  default_data)
486 
487  !Inputs/outputs
488  integer(INT_KIND),intent(in) :: funit !<A file unit for the to which the data will be written.
489  type(fieldtype),intent(inout) :: field !<A field whose data will be written
490  type(domainUG),intent(inout) :: domain !<An unstructured mpp domain associatd with the inputted file.
491  real,dimension(:,:,:,:),intent(inout) :: fdata !<The data that will be written to the file.
492  integer,dimension(:),intent(in),optional :: nelems_io_in !<Number of grid points in the unstructured dimension for each rank (correct
493  !!sizes only exist for the root rank of I/O domain pelist.)
494  real,intent(in),optional :: tstamp !<A time value.
495  real,intent(in), optional :: default_data !<Fill value for the inputted field.
496 
497  !Local variables
498  real :: fill !<Fill value for the inputted field. This defaults to zero.
499  type(domainUG),pointer :: io_domain !<Pointer to the unstructured I/O domain.
500  integer(INT_KIND) :: io_domain_npes !<The total number of ranks in an I/O domain pelist.
501  integer(INT_KIND),dimension(:),allocatable :: pelist !<A pelist.
502  integer(INT_KIND),dimension(:),allocatable :: nelems_io !<Number of grid points in the unstructured dimension for each rank.
503  integer(INT_KIND) :: compute_size !<Size of the unstructured compute domain for the current rank.
504  integer(INT_KIND),dimension(:),allocatable :: dim_size_gather !<Array used to check that size(fdata,2) and size(fdata,3) (non-unstructured dimensions) are the same for
505  !!all ranks in an I/O domain.
506  integer(INT_KIND) :: size_fdata_dim_2 !<Number of data points in a non-unstructured dimension (size(fdata,2)).
507  integer(INT_KIND) :: size_fdata_dim_3 !<Number of data points in a non-unstructured dimension (size(fdata,3)).
508  integer(INT_KIND) :: size_fdata_dim_4 !<Number of data points in a non-unstructured dimension (size(fdata,3)).
509  integer(INT_KIND) :: mynelems !<Number of data points in the unstructured dimension (size(fdata,1)).
510  real,dimension(:),allocatable :: sbuff !<Buffer used to gather the data onto the root rank of the pelist.
511  integer(INT_KIND) :: nelems !<Total number of unstructured data points (sum(nelems_io) for the root rank of the pelist).
512  real,dimension(:),allocatable :: rbuff !<Buffer used to gather the data onto the root rank of the pelist.
513  real,dimension(:,:,:,:),allocatable :: cdata !<Array used to write the data to the file after the gather is performed.
514  integer(INT_KIND) :: i !<Loop variable.
515  integer(INT_KIND) :: j !<Loop variable.
516  integer(INT_KIND) :: k !<Loop variable.
517  integer(INT_KIND) :: n !<Loop variable.
518 
519  !Start the mpp timer.
520  !mpp_write_clock is a module variable.
521  call mpp_clock_begin(mpp_write_clock)
522 
523  !Make sure that the module is initialized.
524  if (.not. module_is_initialized) then
525  call mpp_error(FATAL, &
526  "mpp_io_unstructured_write_compressed_r_4D:" &
527  //" you must first call mpp_io_init.")
528  endif
529 
530  !Make sure that another NetCDF file is not currently using the inputted
531  !file unit.
532  if (.not. mpp_file(funit)%valid) then
533  call mpp_error(FATAL, &
534  "mpp_io_unstructured_write_compressed_r_4D:" &
535  //" the inputted file unit is already in use.")
536  endif
537 
538  !Set the fill value for the field.
539  fill = 0.0
540  if (present(default_data)) then
541  fill = default_data
542  endif
543 
544  !Point to the I/O domain associated with the inputted unstructured mpp
545  !domain.
546  io_domain => null()
547  io_domain => mpp_get_UG_io_domain(domain)
548 
549  !Get the pelist associated with the I/O domain.
550  io_domain_npes = mpp_get_UG_domain_npes(io_domain)
551  allocate(pelist(io_domain_npes))
552  call mpp_get_UG_domain_pelist(io_domain, &
553  pelist)
554 
555  !Make sure that only the root rank of the pelist will write to the file.
556  !This check is needed because data is only gathered on the lowest rank
557  !of the pelist.
558  if (mpp_pe() .eq. pelist(1) .and. .not. &
559  mpp_file(funit)%write_on_this_pe) then
560  call mpp_error(FATAL, &
561  "mpp_io_unstructured_write_compressed_r_4D:" &
562  //" the root rank of the pelist must be allowed" &
563  //" to perform the write.")
564  endif
565  if (mpp_pe() .ne. pelist(1) .and. mpp_file(funit)%write_on_this_pe) then
566  call mpp_error(FATAL, &
567  "mpp_io_unstructured_write_compressed_r_4D:" &
568  //" the non-root ranks of the pelist are not" &
569  //" allowed to perform the write.")
570  endif
571 
572  !For the 3D unstructured case, data is assumed to be of the form
573  !fdata = fdata(unstructured,z,cc). The number of data elements in the
574  !unstructured dimension (size(fdata,1)) may differ between ranks.
575  !If not passed in, the number of data elements in the unstructured
576  !dimension must be gathered on the root rank of the pelist. The number
577  !data elements in the unstructured dimension should be equal to the size
578  !of the unstructured computed domain.
579  if (present(nelems_io_in)) then
580  allocate(nelems_io(size(nelems_io_in)))
581  nelems_io = nelems_io_in
582  else
583  allocate(nelems_io(io_domain_npes))
584  nelems_io = 0
585  call mpp_get_UG_compute_domains(io_domain, &
586  size=nelems_io)
587  endif
588 
589  !The number of data elements in the non-unstructured dimensions are
590  !required to be the same for all ranks. Perform gathers to check this.
591  size_fdata_dim_2 = size(fdata,2)
592  size_fdata_dim_3 = size(fdata,3)
593  size_fdata_dim_4 = size(fdata,4)
594 
595  !Allocate arrays which will be used to gather the data to be written
596  !onto the root rank of the pelist.
597  mynelems = size(fdata,1)
598  allocate(sbuff(mynelems*size_fdata_dim_2*size_fdata_dim_3*size_fdata_dim_4))
599  if (mpp_pe() .eq. pelist(1)) then
600  nelems = sum(nelems_io)
601  allocate(rbuff(nelems*size_fdata_dim_2*size_fdata_dim_3*size_fdata_dim_4))
602  else
603  allocate(rbuff(1))
604  endif
605 
606  !Load the data into the sbuff array. The data is transposed so that the
607  !gather may be performed more easily.
608  do k = 1,mynelems
609  do j = 1,size_fdata_dim_2
610  do i = 1,size_fdata_dim_3
611  do n = 1,size_fdata_dim_4
612  sbuff((k-1)*size_fdata_dim_2*size_fdata_dim_3*size_fdata_dim_4 &
613  + (j-1)*size_fdata_dim_3*size_fdata_dim_4 &
614  + (i-1)*size_fdata_dim_4 + n) = fdata(k,j,i,n)
615  enddo
616  enddo
617  enddo
618  enddo
619 
620  !Perform the gather of data onto the root rank (pelist(1)).
621  call mpp_gather(sbuff, &
622  size(sbuff), &
623  rbuff, &
624  nelems_io*size_fdata_dim_2*size_fdata_dim_3*size_fdata_dim_4, &
625  pelist)
626 
627  !Write out the data to the file. This is only done by the root rank
628  !of the pelist.
629  if (mpp_pe() .eq. pelist(1)) then
630  allocate(cdata(nelems,size_fdata_dim_2,size_fdata_dim_3,size_fdata_dim_4))
631  cdata = fill
632  do n = 1,size_fdata_dim_4
633  do k = 1,size_fdata_dim_3
634  do j = 1,size_fdata_dim_2
635  do i = 1,nelems
636  cdata(i,j,k,n) = rbuff((i-1)*size_fdata_dim_2*size_fdata_dim_3*size_fdata_dim_4 &
637  + (j-1)*size_fdata_dim_3*size_fdata_dim_4 &
638  + (k-1)*size_fdata_dim_4 + n)
639  enddo
640  enddo
641  enddo
642  enddo
643  field%size(1) = nelems
644  call write_record_default(funit, &
645  field, &
646  nelems*size_fdata_dim_2*size_fdata_dim_3*size_fdata_dim_4, &
647  cdata, &
648  tstamp)
649  deallocate(cdata)
650  endif
651 
652  !Deallocate local allocatables.
653  deallocate(sbuff)
654  deallocate(rbuff)
655  deallocate(pelist)
656  deallocate(nelems_io)
657 
658  !Stop the mpp timer.
659  call mpp_clock_end(mpp_write_clock)
660 
661  return
662 end subroutine mpp_io_unstructured_write_r_4D
663 
664 !------------------------------------------------------------------------------
665 
666 !----------
will
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version will
Definition: mpp_transmit_mpi.h:166
time_interp_external_mod::field
type(ext_fieldtype), dimension(:), pointer, save, private field
Definition: time_interp_external.F90:137
mpp_io_mod::mpp_write_clock
integer mpp_write_clock
Definition: mpp_io.F90:1054
odps_coordinatemapping::cc
real(fp), parameter cc
Definition: ODPS_CoordinateMapping.f90:51
integer
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_UPDATE_NEST_FINE_2D_(field, nest_domain, wbuffer, ebuffer, sbuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) MPP_TYPE_ ::wbuffer3D(size(wbuffer, 1), size(wbuffer, 2), 1) MPP_TYPE_ ::ebuffer3D(size(ebuffer, 1), size(ebuffer, 2), 1) MPP_TYPE_ ::sbuffer3D(size(sbuffer, 1), size(sbuffer, 2), 1) MPP_TYPE_ ::nbuffer3D(size(nbuffer, 1), size(nbuffer, 2), 1) pointer(ptr, field3D) pointer(ptr_w, wbuffer3D) pointer(ptr_e, ebuffer3D) pointer(ptr_s, sbuffer3D) pointer(ptr_n, nbuffer3D) ptr=LOC(field) ptr_w=LOC(wbuffer) ptr_e=LOC(ebuffer) ptr_s=LOC(sbuffer) ptr_n=LOC(nbuffer) call mpp_update_nest_fine(field3D, nest_domain, wbuffer3D, ebuffer3D, sbuffer3D, nbuffer3D, &flags, complete, position, extra_halo, name, tile_count) returnend subroutine MPP_UPDATE_NEST_FINE_2D_subroutine MPP_UPDATE_NEST_FINE_3D_(field, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::d_type type(nestSpec), pointer ::update=> set_mismatch integer ::tile update_position nbuffersz l_size integer
Definition: mpp_update_nest_domains.h:79
i
l_size ! loop over number of fields ke do je do i
Definition: mpp_do_redistribute.h:71
unit
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> unit
Definition: mpp_read_2Ddecomp.h:167
write_ocean_data_mod::time
type(time_type) time
Definition: write_ocean_data.F90:49
field_manager_mod::equal
character(len=1), parameter equal
Definition: field_manager.F90:473
crtm_lowfrequency_mwssem::n
integer n
Definition: CRTM_LowFrequency_MWSSEM.f90:172
allocatable
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_WRITE_UNLIMITED_AXIS_1D_(unit, field, domain, data, nelems_io) integer, intent(in) ::unit type(fieldtype), intent(inout) ::field type(domain2D), intent(inout) ::domain MPP_TYPE_, intent(inout) ::data(:) integer, intent(in) ::nelems_io(:) ! number of compressed elements from each ! member of the io_domain. It MUST have the ! same order as the io_domain pelist. integer, allocatable ::pelist(:) integer ::i, j, nelems, npes type(domain2d), pointer ::io_domain=> allocatable
Definition: mpp_write_unlimited_axis.h:30
fv3jedi_increment_mod::copy
subroutine, public copy(self, rhs)
Definition: fv3jedi_increment_mod.f90:254
end
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT end
Definition: mpp_transmit_mpi.h:153
make_check_data.out
out
Definition: make_check_data.py:458
j
l_size ! loop over number of fields ke do j
Definition: mpp_do_redistribute.h:70
stock_constants_mod::nelems
integer, parameter, public nelems
Definition: stock_constants.F90:33
cdata
only root needs to know the vector of recv size nz do nelems cdata(i, j)
if
l_size ! loop over number of fields ke do je do ie to je n if(.NOT. d_comm%R_do_buf(list)) cycle from_pe
amip_interp_mod::module_is_initialized
logical module_is_initialized
Definition: amip_interp.F90:272
mersennetwister_mod::m
integer, parameter m
Definition: MersenneTwister.F90:79
diag_integral_mod::version
character(len=128) version
Definition: diag_integral.F90:121
accoeff_define::zero
real(double), parameter zero
Definition: ACCoeff_Define.f90:68
is
l_size ! loop over number of fields ke do je do ie to is
Definition: mpp_do_redistribute.h:72
c2f.type
type
Definition: c2f.py:15
mpp_file
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> mpp_file(unit)%id
mpp_error
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call mpp_error(FATAL, 'MPP_TRANSMIT:you cannot transmit to ANY_PE using MPI.') else if(to_pe.NE.NULL_PE) then !no other valid cases except NULL_PE call mpp_error(FATAL
gsw_mod_sp_coefficients::k
real(r8), parameter k
Definition: gsw_mod_sp_coefficients.f90:40
case
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> tlevel if(PRESENT(start_in) .AND. PRESENT(axsiz_in)) then if(size(start(! the data domain and compute domain must refer to the subdomain being passed ! In this case
Definition: mpp_read_2Ddecomp.h:169
fv_control_nlm_mod::fill
logical, pointer fill
Definition: fv_control_nlm.F90:170
accoeff_define::one
real(double), parameter one
Definition: ACCoeff_Define.f90:69
type_distribution::received
logical function received(this, seqno)
Definition: m_distribution.f90:72
fv3jedi_increment_mod::check
subroutine check(self)
Definition: fv3jedi_increment_mod.f90:1932
fms_io_mod::form
integer form
Definition: fms_io.F90:484
field_manager_mod::root
type(field_def), target, save root
Definition: field_manager.F90:564
size
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> tlevel if(PRESENT(start_in) .AND. PRESENT(axsiz_in)) then if(size(start(! the data domain and compute domain must refer to the subdomain being passed ! In this ! since that attempts to gather all data on PE size(field%axes(:)) axsiz(i)
a
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version and mpp_transmit will remain !backward compatible intent(inout) a
Definition: mpp_transmit_mpi.h:178
dimension
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_UPDATE_NEST_FINE_2D_(field, nest_domain, wbuffer, ebuffer, sbuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) MPP_TYPE_ ::wbuffer3D(size(wbuffer, 1), size(wbuffer, 2), 1) MPP_TYPE_ ::ebuffer3D(size(ebuffer, 1), size(ebuffer, 2), 1) MPP_TYPE_ ::sbuffer3D(size(sbuffer, 1), size(sbuffer, 2), 1) MPP_TYPE_ ::nbuffer3D(size(nbuffer, 1), size(nbuffer, 2), 1) pointer(ptr, field3D) pointer(ptr_w, wbuffer3D) pointer(ptr_e, ebuffer3D) pointer(ptr_s, sbuffer3D) pointer(ptr_n, nbuffer3D) ptr=LOC(field) ptr_w=LOC(wbuffer) ptr_e=LOC(ebuffer) ptr_s=LOC(sbuffer) ptr_n=LOC(nbuffer) call mpp_update_nest_fine(field3D, nest_domain, wbuffer3D, ebuffer3D, sbuffer3D, nbuffer3D, &flags, complete, position, extra_halo, name, tile_count) returnend subroutine MPP_UPDATE_NEST_FINE_2D_subroutine MPP_UPDATE_NEST_FINE_3D_(field, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::d_type type(nestSpec), pointer ::update=> dimension(MAX_DOMAIN_FIELDS)
station_data_mod::pelist
integer, dimension(:), allocatable pelist
Definition: station_data.F90:293
not
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If not
Definition: drifters_compute_k.h:5
INT_KIND
#define INT_KIND
sbuff
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_WRITE_COMPRESSED_1D_(unit, field, domain, data, nelems_io, tstamp, default_data) integer, intent(in) ::unit type(fieldtype), intent(inout) ::field type(domain2D), intent(inout) ::domain MPP_TYPE_, intent(inout) ::data(:) integer, intent(in) ::nelems_io(:) ! number of compressed elements real, intent(in), optional ::tstamp MPP_TYPE_, intent(in), optional ::default_data MPP_TYPE_ ::data2D(size(data, 1), 1) pointer(ptr, data2D) ptr=LOC(data) call mpp_write_compressed(unit, field, domain, data2D, nelems_io, tstamp, default_data) return end subroutine MPP_WRITE_COMPRESSED_1D_ subroutine MPP_WRITE_COMPRESSED_3D_(unit, field, domain, data, nelems_io, tstamp, default_data) integer, intent(in) ::unit type(fieldtype), intent(inout) ::field type(domain2D), intent(inout) ::domain MPP_TYPE_, intent(inout) ::data(:,:,:) integer, intent(in) ::nelems_io(:) ! number of compressed elements real, intent(in), optional ::tstamp MPP_TYPE_, intent(in), optional ::default_data MPP_TYPE_ ::data2D(size(data, 1), size(data, 2) *size(data, 3)) pointer(ptr, data2D) ptr=LOC(data) call mpp_write_compressed(unit, field, domain, data2D, nelems_io, tstamp, default_data) return end subroutine MPP_WRITE_COMPRESSED_3D_ subroutine MPP_WRITE_COMPRESSED_2D_(unit, field, domain, data, nelems_io, tstamp, default_data) integer, intent(in) ::unit type(fieldtype), intent(inout) ::field type(domain2D), intent(inout) ::domain MPP_TYPE_, intent(inout) ::data(:,:) integer, intent(in) ::nelems_io(:) ! number of compressed elements from each ! member of the io_domain. It MUST have the ! same order as the io_domain pelist. real, intent(in), optional ::tstamp MPP_TYPE_, intent(in), optional ::default_data!cdata is used to store the io-domain compressed data MPP_TYPE_, allocatable, dimension(:,:) ::cdata MPP_TYPE_, allocatable, dimension(:,:) ::sbuff, rbuff MPP_TYPE_ ::fill MPP_TYPE_ ::sbuff1D(size(data)) MPP_TYPE_ ::rbuff1D(size(data, 2) *sum(nelems_io(:))) pointer(sptr, sbuff1D);pointer(rptr, rbuff1D) integer, allocatable ::pelist(:) integer, allocatable ::nz_gather(:) integer ::i, j, nz, nelems, mynelems, idx, npes type(domain2d), pointer ::io_domain=> pelist concise unpack do mynelems do nz sbuff(i, j)
c2f.module
module
Definition: c2f.py:21
tools_repro::eq
logical function, public eq(x, y)
Definition: tools_repro.F90:28
mynelems
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_WRITE_COMPRESSED_1D_(unit, field, domain, data, nelems_io, tstamp, default_data) integer, intent(in) ::unit type(fieldtype), intent(inout) ::field type(domain2D), intent(inout) ::domain MPP_TYPE_, intent(inout) ::data(:) integer, intent(in) ::nelems_io(:) ! number of compressed elements real, intent(in), optional ::tstamp MPP_TYPE_, intent(in), optional ::default_data MPP_TYPE_ ::data2D(size(data, 1), 1) pointer(ptr, data2D) ptr=LOC(data) call mpp_write_compressed(unit, field, domain, data2D, nelems_io, tstamp, default_data) return end subroutine MPP_WRITE_COMPRESSED_1D_ subroutine MPP_WRITE_COMPRESSED_3D_(unit, field, domain, data, nelems_io, tstamp, default_data) integer, intent(in) ::unit type(fieldtype), intent(inout) ::field type(domain2D), intent(inout) ::domain MPP_TYPE_, intent(inout) ::data(:,:,:) integer, intent(in) ::nelems_io(:) ! number of compressed elements real, intent(in), optional ::tstamp MPP_TYPE_, intent(in), optional ::default_data MPP_TYPE_ ::data2D(size(data, 1), size(data, 2) *size(data, 3)) pointer(ptr, data2D) ptr=LOC(data) call mpp_write_compressed(unit, field, domain, data2D, nelems_io, tstamp, default_data) return end subroutine MPP_WRITE_COMPRESSED_3D_ subroutine MPP_WRITE_COMPRESSED_2D_(unit, field, domain, data, nelems_io, tstamp, default_data) integer, intent(in) ::unit type(fieldtype), intent(inout) ::field type(domain2D), intent(inout) ::domain MPP_TYPE_, intent(inout) ::data(:,:) integer, intent(in) ::nelems_io(:) ! number of compressed elements from each ! member of the io_domain. It MUST have the ! same order as the io_domain pelist. real, intent(in), optional ::tstamp MPP_TYPE_, intent(in), optional ::default_data!cdata is used to store the io-domain compressed data MPP_TYPE_, allocatable, dimension(:,:) ::cdata MPP_TYPE_, allocatable, dimension(:,:) ::sbuff, rbuff MPP_TYPE_ ::fill MPP_TYPE_ ::sbuff1D(size(data)) MPP_TYPE_ ::rbuff1D(size(data, 2) *sum(nelems_io(:))) pointer(sptr, sbuff1D);pointer(rptr, rbuff1D) integer, allocatable ::pelist(:) integer, allocatable ::nz_gather(:) integer ::i, j, nz, nelems, mynelems, idx, npes type(domain2d), pointer ::io_domain=> pelist mynelems
Definition: mpp_write_compressed.h:91