Oasis3-MCT
mod_oasis_getput_interface.F90
Go to the documentation of this file.
1 
2 !> OASIS send/receive (put/get) user interfaces
3 
4 MODULE mod_oasis_getput_interface
5 !---------------------------------------------------------------------
6 
7  use mod_oasis_kinds
8  use mod_oasis_data
9  use mod_oasis_parameters
10  use mod_oasis_advance
11  use mod_oasis_var
12  use mod_oasis_sys
13  use mct_mod
14 
15  implicit none
16  private
17 
18  public oasis_put
19  public oasis_get
20 
21 #include "oasis_os.h"
22 
23  integer(kind=ip_i4_p) istatus(mpi_status_size)
24 
25 !> Generic overloaded interface for data put (send)
26  interface oasis_put
27 #ifndef __NO_4BYTE_REALS
28  module procedure oasis_put_r14
29  module procedure oasis_put_r24
30  module procedure oasis_put_r34
31 #endif
32  module procedure oasis_put_r18
33  module procedure oasis_put_r28
34  module procedure oasis_put_r38
35  end interface
36 
37 !> Generic overloaded interface for data get (receive)
38  interface oasis_get
39 #ifndef __NO_4BYTE_REALS
40  module procedure oasis_get_r14
41  module procedure oasis_get_r24
42  module procedure oasis_get_r34
43 #endif
44  module procedure oasis_get_r18
45  module procedure oasis_get_r28
46  module procedure oasis_get_r38
47  end interface
48 
49 !---------------------------------------------------------------------
50 contains
51 !---------------------------------------------------------------------
52 #ifndef __NO_4BYTE_REALS
53 
54 !> Send 4 byte real 1D data
55 
56  SUBROUTINE oasis_put_r14(var_id,kstep,fld1,kinfo, &
57  fld2, fld3, fld4, fld5, write_restart)
58 
59  IMPLICIT none
60  !-------------------------------------
61  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
62  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
63  real(kind=ip_single_p) :: fld1(:) !< field data
64  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
65  real(kind=ip_single_p), optional :: fld2(:) !< higher order field data
66  real(kind=ip_single_p), optional :: fld3(:) !< higher order field data
67  real(kind=ip_single_p), optional :: fld4(:) !< higher order field data
68  real(kind=ip_single_p), optional :: fld5(:) !< higher order field data
69  logical , optional :: write_restart !< write restart now
70  !-------------------------------------
71  logical :: lwrst
72  character(len=*),parameter :: subname = '(oasis_put_r14)'
73  !-------------------------------------
74 
75  call oasis_debug_enter(subname)
76  kinfo = oasis_ok
77  if (.not. oasis_coupled) then
78  call oasis_debug_exit(subname)
79  return
80  endif
81 
82  if (prism_var(var_id)%num > 1) then
83  write(nulprt,*) subname,estr,'called for variable ',trim(prism_var(var_id)%name)
84  write(nulprt,*) subname,estr,'expecting bundled field with num = ',prism_var(var_id)%num
85  call oasis_abort(file=__file__,line=__line__)
86  endif
87 
88  if (present(write_restart)) then
89  lwrst = write_restart
90  else
91  lwrst = .false.
92  endif
93 
94  if (present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
95  CALL oasis_put_worker(var_id,kstep,dble(fld1),kinfo,dble(fld2), &
96  dble(fld3),dble(fld4),dble(fld5),write_restart=lwrst)
97  elseif (.not.present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
98  CALL oasis_put_worker(var_id,kstep,dble(fld1),kinfo,dble(fld2), &
99  dble(fld3),dble(fld4),write_restart=lwrst)
100  elseif (.not.present(fld5) .and. .not.present(fld4) .and. present(fld3) .and. present(fld2)) then
101  CALL oasis_put_worker(var_id,kstep,dble(fld1),kinfo,dble(fld2), &
102  dble(fld3),write_restart=lwrst)
103  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. present(fld2)) then
104  CALL oasis_put_worker(var_id,kstep,dble(fld1),kinfo,dble(fld2), &
105  write_restart=lwrst)
106  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. .not.present(fld2)) then
107  CALL oasis_put_worker(var_id,kstep,dble(fld1),kinfo,write_restart=lwrst)
108  else
109  WRITE(nulprt,*) subname,estr,' Wrong field array argument list in oasis_put'
110  call oasis_abort(file=__file__,line=__line__)
111  endif
112 
113  call oasis_debug_exit(subname)
114 
115  END SUBROUTINE oasis_put_r14
116 #endif
117 
118 !-------------------------------------------------------------------
119 
120 !> Send 4 byte real 1D data
121 
122  SUBROUTINE oasis_put_r18(var_id,kstep,fld1,kinfo, &
123  fld2, fld3, fld4, fld5, write_restart)
124 
125  IMPLICIT none
126  !-------------------------------------
127  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
128  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
129  real(kind=ip_double_p) :: fld1(:) !< field data
130  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
131  real(kind=ip_double_p), optional :: fld2(:) !< higher order field data
132  real(kind=ip_double_p), optional :: fld3(:) !< higher order field data
133  real(kind=ip_double_p), optional :: fld4(:) !< higher order field data
134  real(kind=ip_double_p), optional :: fld5(:) !< higher order field data
135  logical , optional :: write_restart !< write restart now
136  !-------------------------------------
137  logical :: lwrst
138  character(len=*),parameter :: subname = '(oasis_put_r18)'
139  !-------------------------------------
140 
141  call oasis_debug_enter(subname)
142  kinfo = oasis_ok
143  if (.not. oasis_coupled) then
144  call oasis_debug_exit(subname)
145  return
146  endif
147 
148  if (prism_var(var_id)%num > 1) then
149  write(nulprt,*) subname,estr,'called for variable ',trim(prism_var(var_id)%name)
150  write(nulprt,*) subname,estr,'expecting bundled field with num = ',prism_var(var_id)%num
151  call oasis_abort(file=__file__,line=__line__)
152  endif
153 
154  if (present(write_restart)) then
155  lwrst = write_restart
156  else
157  lwrst = .false.
158  endif
159 
160  if (present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
161  CALL oasis_put_worker(var_id,kstep,fld1,kinfo,fld2, &
162  fld3,fld4,fld5,write_restart=lwrst)
163  elseif (.not.present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
164  CALL oasis_put_worker(var_id,kstep,fld1,kinfo,fld2, &
165  fld3,fld4,write_restart=lwrst)
166  elseif (.not.present(fld5) .and. .not.present(fld4) .and. present(fld3) .and. present(fld2)) then
167  CALL oasis_put_worker(var_id,kstep,fld1,kinfo,fld2, &
168  fld3,write_restart=lwrst)
169  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. present(fld2)) then
170  CALL oasis_put_worker(var_id,kstep,fld1,kinfo,fld2, &
171  write_restart=lwrst)
172  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. .not.present(fld2)) then
173  CALL oasis_put_worker(var_id,kstep,fld1,kinfo,write_restart=lwrst)
174  else
175  WRITE(nulprt,*) subname,estr,' Wrong field array argument list in oasis_put'
176  call oasis_abort(file=__file__,line=__line__)
177  endif
178 
179  call oasis_debug_exit(subname)
180 
181  END SUBROUTINE oasis_put_r18
182 
183 !---------------------------------------------------------------------
184 #ifndef __NO_4BYTE_REALS
185 
186 !> Send 4 byte real 2D data
187 
188  SUBROUTINE oasis_put_r24(var_id,kstep,fld1,kinfo, &
189  fld2, fld3, fld4, fld5, write_restart)
190 
191  IMPLICIT none
192  !-------------------------------------
193  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
194  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
195  real(kind=ip_single_p) :: fld1(:,:) !< field data
196  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
197  real(kind=ip_single_p), optional :: fld2(:,:) !< higher order field data
198  real(kind=ip_single_p), optional :: fld3(:,:) !< higher order field data
199  real(kind=ip_single_p), optional :: fld4(:,:) !< higher order field data
200  real(kind=ip_single_p), optional :: fld5(:,:) !< higher order field data
201  logical , optional :: write_restart !< write restart now
202  !-------------------------------------
203  logical :: lwrst
204  integer(kind=ip_i4_p) :: n, size_fld1
205  character(len=*),parameter :: subname = '(oasis_put_r24)'
206  !-------------------------------------
207 
208  call oasis_debug_enter(subname)
209  kinfo = oasis_ok
210  if (.not. oasis_coupled) then
211  call oasis_debug_exit(subname)
212  return
213  endif
214 
215  if (present(write_restart)) then
216  lwrst = write_restart
217  else
218  lwrst = .false.
219  endif
220 
221  if (prism_var(var_id)%num > 1) then
222  ! treat data as 1d bundled data
223 
224  if (size(fld1,dim=2) /= prism_var(var_id)%num) then
225  write(nulprt,*) subname,estr,'called for variable ',trim(prism_var(var_id)%name)
226  write(nulprt,*) subname,estr,'expecting bundled field with num = ',prism_var(var_id)%num
227  write(nulprt,*) subname,estr,'passing in field with incorrect 2nd dim size = ',size(fld1,dim=2)
228  call oasis_abort(file=__file__,line=__line__)
229  endif
230 
231  size_fld1 = size(fld1,dim=2)
232  if (present(fld2)) then
233  if (size(fld2,dim=2) /= size_fld1) then
234  write(nulprt,*) subname,estr,'fld2 size different than fld1 size ',size_fld1,size(fld2,dim=2)
235  call oasis_abort(file=__file__,line=__line__)
236  endif
237  endif
238  if (present(fld3)) then
239  if (size(fld3,dim=2) /= size_fld1) then
240  write(nulprt,*) subname,estr,'fld3 size different than fld1 size ',size_fld1,size(fld3,dim=2)
241  call oasis_abort(file=__file__,line=__line__)
242  endif
243  endif
244  if (present(fld4)) then
245  if (size(fld4,dim=2) /= size_fld1) then
246  write(nulprt,*) subname,estr,'fld4 size different than fld1 size ',size_fld1,size(fld4,dim=2)
247  call oasis_abort(file=__file__,line=__line__)
248  endif
249  endif
250  if (present(fld5)) then
251  if (size(fld5,dim=2) /= size_fld1) then
252  write(nulprt,*) subname,estr,'fld5 size different than fld1 size ',size_fld1,size(fld5,dim=2)
253  call oasis_abort(file=__file__,line=__line__)
254  endif
255  endif
256 
257  do n = 1,prism_var(var_id)%num
258  if (present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
259  CALL oasis_put_worker(var_id,kstep,dble(fld1(:,n)),kinfo,dble(fld2(:,n)), &
260  dble(fld3(:,n)),dble(fld4(:,n)),dble(fld5(:,n)),write_restart=lwrst,varnum=n)
261  elseif (.not.present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
262  CALL oasis_put_worker(var_id,kstep,dble(fld1(:,n)),kinfo,dble(fld2(:,n)), &
263  dble(fld3(:,n)),dble(fld4(:,n)),write_restart=lwrst,varnum=n)
264  elseif (.not.present(fld5) .and. .not.present(fld4) .and. present(fld3) .and. present(fld2)) then
265  CALL oasis_put_worker(var_id,kstep,dble(fld1(:,n)),kinfo,dble(fld2(:,n)), &
266  dble(fld3(:,n)),write_restart=lwrst,varnum=n)
267  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. present(fld2)) then
268  CALL oasis_put_worker(var_id,kstep,dble(fld1(:,n)),kinfo,dble(fld2(:,n)), &
269  write_restart=lwrst,varnum=n)
270  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. .not.present(fld2)) then
271  CALL oasis_put_worker(var_id,kstep,dble(fld1(:,n)),kinfo,write_restart=lwrst,varnum=n)
272  else
273  WRITE(nulprt,*) subname,estr,' Wrong field array argument list in oasis_put'
274  call oasis_abort(file=__file__,line=__line__)
275  endif
276  enddo
277 
278  else
279  ! treat data as 2d unbundled data
280 
281  if (present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
282  CALL oasis_put_worker(var_id,kstep,dble(pack(fld1,mask=.true.)),kinfo,dble(pack(fld2,mask=.true.)), &
283  dble(pack(fld3,mask=.true.)),dble(pack(fld4,mask=.true.)),dble(pack(fld5,mask=.true.)),write_restart=lwrst)
284  elseif (.not.present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
285  CALL oasis_put_worker(var_id,kstep,dble(pack(fld1,mask=.true.)),kinfo,dble(pack(fld2,mask=.true.)), &
286  dble(pack(fld3,mask=.true.)),dble(pack(fld4,mask=.true.)),write_restart=lwrst)
287  elseif (.not.present(fld5) .and. .not.present(fld4) .and. present(fld3) .and. present(fld2)) then
288  CALL oasis_put_worker(var_id,kstep,dble(pack(fld1,mask=.true.)),kinfo,dble(pack(fld2,mask=.true.)), &
289  dble(pack(fld3,mask=.true.)),write_restart=lwrst)
290  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. present(fld2)) then
291  CALL oasis_put_worker(var_id,kstep,dble(pack(fld1,mask=.true.)),kinfo,dble(pack(fld2,mask=.true.)), &
292  write_restart=lwrst)
293  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. .not.present(fld2)) then
294  CALL oasis_put_worker(var_id,kstep,dble(pack(fld1,mask=.true.)),kinfo,write_restart=lwrst)
295  else
296  WRITE(nulprt,*) subname,estr,' Wrong field array argument list in oasis_put'
297  call oasis_abort(file=__file__,line=__line__)
298  endif
299 
300  endif
301 
302  call oasis_debug_exit(subname)
303 
304  END SUBROUTINE oasis_put_r24
305 #endif
306 
307 !---------------------------------------------------------------------
308 #ifndef __NO_4BYTE_REALS
309 
310 !> Send 4 byte real 2D bundled data
311 
312  SUBROUTINE oasis_put_r34(var_id,kstep,fld1,kinfo, &
313  fld2, fld3, fld4, fld5, write_restart)
314 
315  IMPLICIT none
316  !-------------------------------------
317  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
318  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
319  real(kind=ip_single_p) :: fld1(:,:,:) !< field data
320  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
321  real(kind=ip_single_p), optional :: fld2(:,:,:) !< higher order field data
322  real(kind=ip_single_p), optional :: fld3(:,:,:) !< higher order field data
323  real(kind=ip_single_p), optional :: fld4(:,:,:) !< higher order field data
324  real(kind=ip_single_p), optional :: fld5(:,:,:) !< higher order field data
325  logical , optional :: write_restart !< write restart now
326  !-------------------------------------
327  logical :: lwrst
328  integer(kind=ip_i4_p) :: n, size_fld1
329  character(len=*),parameter :: subname = '(oasis_put_r34)'
330  !-------------------------------------
331 
332  call oasis_debug_enter(subname)
333  kinfo = oasis_ok
334  if (.not. oasis_coupled) then
335  call oasis_debug_exit(subname)
336  return
337  endif
338 
339  if (present(write_restart)) then
340  lwrst = write_restart
341  else
342  lwrst = .false.
343  endif
344 
345  if (prism_var(var_id)%num > 1) then
346  ! treat data as 2d bundled data
347 
348  if (size(fld1,dim=3) /= prism_var(var_id)%num) then
349  write(nulprt,*) subname,estr,'called for variable ',trim(prism_var(var_id)%name)
350  write(nulprt,*) subname,estr,'expecting bundled field with num = ',prism_var(var_id)%num
351  write(nulprt,*) subname,estr,'passing in field with incorrect 3rd dim size = ',size(fld1,dim=3)
352  call oasis_abort(file=__file__,line=__line__)
353  endif
354 
355  size_fld1 = size(fld1,dim=3)
356  if (present(fld2)) then
357  if (size(fld2,dim=3) /= size_fld1) then
358  write(nulprt,*) subname,estr,'fld2 size different than fld1 size ',size_fld1,size(fld2,dim=3)
359  call oasis_abort(file=__file__,line=__line__)
360  endif
361  endif
362  if (present(fld3)) then
363  if (size(fld3,dim=3) /= size_fld1) then
364  write(nulprt,*) subname,estr,'fld3 size different than fld1 size ',size_fld1,size(fld3,dim=3)
365  call oasis_abort(file=__file__,line=__line__)
366  endif
367  endif
368  if (present(fld4)) then
369  if (size(fld4,dim=3) /= size_fld1) then
370  write(nulprt,*) subname,estr,'fld4 size different than fld1 size ',size_fld1,size(fld4,dim=3)
371  call oasis_abort(file=__file__,line=__line__)
372  endif
373  endif
374  if (present(fld5)) then
375  if (size(fld5,dim=3) /= size_fld1) then
376  write(nulprt,*) subname,estr,'fld5 size different than fld1 size ',size_fld1,size(fld5,dim=3)
377  call oasis_abort(file=__file__,line=__line__)
378  endif
379  endif
380 
381  do n = 1,prism_var(var_id)%num
382  if (present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
383  CALL oasis_put_worker(var_id,kstep,dble(pack(fld1(:,:,n),mask=.true.)),kinfo,dble(pack(fld2(:,:,n),mask=.true.)), &
384  dble(pack(fld3(:,:,n),mask=.true.)),dble(pack(fld4(:,:,n),mask=.true.)),dble(pack(fld5(:,:,n),mask=.true.)), &
385  write_restart=lwrst,varnum=n)
386  elseif (.not.present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
387  CALL oasis_put_worker(var_id,kstep,dble(pack(fld1(:,:,n),mask=.true.)),kinfo,dble(pack(fld2(:,:,n),mask=.true.)), &
388  dble(pack(fld3(:,:,n),mask=.true.)),dble(pack(fld4(:,:,n),mask=.true.)),write_restart=lwrst,varnum=n)
389  elseif (.not.present(fld5) .and. .not.present(fld4) .and. present(fld3) .and. present(fld2)) then
390  CALL oasis_put_worker(var_id,kstep,dble(pack(fld1(:,:,n),mask=.true.)),kinfo,dble(pack(fld2(:,:,n),mask=.true.)), &
391  dble(pack(fld3(:,:,n),mask=.true.)),write_restart=lwrst,varnum=n)
392  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. present(fld2)) then
393  CALL oasis_put_worker(var_id,kstep,dble(pack(fld1(:,:,n),mask=.true.)),kinfo,dble(pack(fld2(:,:,n),mask=.true.)), &
394  write_restart=lwrst,varnum=n)
395  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. .not.present(fld2)) then
396  CALL oasis_put_worker(var_id,kstep,dble(pack(fld1(:,:,n),mask=.true.)),kinfo,write_restart=lwrst,varnum=n)
397  else
398  WRITE(nulprt,*) subname,estr,' Wrong field array argument list in oasis_put'
399  call oasis_abort(file=__file__,line=__line__)
400  endif
401  enddo
402 
403  else
404  WRITE(nulprt,*) subname,estr,' Dimension sizes incorrect'
405  call oasis_abort(file=__file__,line=__line__)
406 
407  endif
408 
409  call oasis_debug_exit(subname)
410 
411  END SUBROUTINE oasis_put_r34
412 #endif
413 !-------------------------------------------------------------------
414 !---------------------------------------------------------------------
415 
416 !> Send 8 byte real 2D data
417 
418  SUBROUTINE oasis_put_r28(var_id,kstep,fld1,kinfo, &
419  fld2, fld3, fld4, fld5, write_restart)
420 
421  IMPLICIT none
422  !-------------------------------------
423  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
424  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
425  real(kind=ip_double_p) :: fld1(:,:) !< field data
426  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
427  real(kind=ip_double_p), optional :: fld2(:,:) !< higher order field data
428  real(kind=ip_double_p), optional :: fld3(:,:) !< higher order field data
429  real(kind=ip_double_p), optional :: fld4(:,:) !< higher order field data
430  real(kind=ip_double_p), optional :: fld5(:,:) !< higher order field data
431  logical , optional :: write_restart !< write restart now
432  !-------------------------------------
433  logical :: lwrst
434  integer(kind=ip_i4_p) :: n, size_fld1
435  character(len=*),parameter :: subname = '(oasis_put_r28)'
436  !-------------------------------------
437 
438  call oasis_debug_enter(subname)
439  kinfo = oasis_ok
440  if (.not. oasis_coupled) then
441  call oasis_debug_exit(subname)
442  return
443  endif
444 
445  if (present(write_restart)) then
446  lwrst = write_restart
447  else
448  lwrst = .false.
449  endif
450 
451  if (prism_var(var_id)%num > 1) then
452  ! treat data as 1d bundled data
453 
454  if (size(fld1,dim=2) /= prism_var(var_id)%num) then
455  write(nulprt,*) subname,estr,'called for variable ',trim(prism_var(var_id)%name)
456  write(nulprt,*) subname,estr,'expecting bundled field with num = ',prism_var(var_id)%num
457  write(nulprt,*) subname,estr,'passing in field with incorrect 2nd dim size = ',size(fld1,dim=2)
458  call oasis_abort(file=__file__,line=__line__)
459  endif
460 
461  size_fld1 = size(fld1,dim=2)
462  if (present(fld2)) then
463  if (size(fld2,dim=2) /= size_fld1) then
464  write(nulprt,*) subname,estr,'fld2 size different than fld1 size ',size_fld1,size(fld2,dim=2)
465  call oasis_abort(file=__file__,line=__line__)
466  endif
467  endif
468  if (present(fld3)) then
469  if (size(fld3,dim=2) /= size_fld1) then
470  write(nulprt,*) subname,estr,'fld3 size different than fld1 size ',size_fld1,size(fld3,dim=2)
471  call oasis_abort(file=__file__,line=__line__)
472  endif
473  endif
474  if (present(fld4)) then
475  if (size(fld4,dim=2) /= size_fld1) then
476  write(nulprt,*) subname,estr,'fld4 size different than fld1 size ',size_fld1,size(fld4,dim=2)
477  call oasis_abort(file=__file__,line=__line__)
478  endif
479  endif
480  if (present(fld5)) then
481  if (size(fld5,dim=2) /= size_fld1) then
482  write(nulprt,*) subname,estr,'fld5 size different than fld1 size ',size_fld1,size(fld5,dim=2)
483  call oasis_abort(file=__file__,line=__line__)
484  endif
485  endif
486 
487  do n = 1,prism_var(var_id)%num
488  if (present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
489  CALL oasis_put_worker(var_id,kstep,(fld1(:,n)),kinfo,(fld2(:,n)), &
490  (fld3(:,n)),(fld4(:,n)),(fld5(:,n)),write_restart=lwrst,varnum=n)
491  elseif (.not.present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
492  CALL oasis_put_worker(var_id,kstep,(fld1(:,n)),kinfo,(fld2(:,n)), &
493  (fld3(:,n)),(fld4(:,n)),write_restart=lwrst,varnum=n)
494  elseif (.not.present(fld5) .and. .not.present(fld4) .and. present(fld3) .and. present(fld2)) then
495  CALL oasis_put_worker(var_id,kstep,(fld1(:,n)),kinfo,(fld2(:,n)), &
496  (fld3(:,n)),write_restart=lwrst,varnum=n)
497  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. present(fld2)) then
498  CALL oasis_put_worker(var_id,kstep,(fld1(:,n)),kinfo,(fld2(:,n)), &
499  write_restart=lwrst,varnum=n)
500  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. .not.present(fld2)) then
501  CALL oasis_put_worker(var_id,kstep,(fld1(:,n)),kinfo,write_restart=lwrst,varnum=n)
502  else
503  WRITE(nulprt,*) subname,estr,' Wrong field array argument list in oasis_put'
504  call oasis_abort(file=__file__,line=__line__)
505  endif
506  enddo
507 
508  else
509  ! treat data as 2d unbundled data
510 
511  if (present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
512  CALL oasis_put_worker(var_id,kstep,pack(fld1,mask=.true.),kinfo,pack(fld2,mask=.true.), &
513  pack(fld3,mask=.true.),pack(fld4,mask=.true.),pack(fld5,mask=.true.),write_restart=lwrst)
514  elseif (.not.present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
515  CALL oasis_put_worker(var_id,kstep,pack(fld1,mask=.true.),kinfo,pack(fld2,mask=.true.), &
516  pack(fld3,mask=.true.),pack(fld4,mask=.true.),write_restart=lwrst)
517  elseif (.not.present(fld5) .and. .not.present(fld4) .and. present(fld3) .and. present(fld2)) then
518  CALL oasis_put_worker(var_id,kstep,pack(fld1,mask=.true.),kinfo,pack(fld2,mask=.true.), &
519  pack(fld3,mask=.true.),write_restart=lwrst)
520  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. present(fld2)) then
521  CALL oasis_put_worker(var_id,kstep,pack(fld1,mask=.true.),kinfo,pack(fld2,mask=.true.), &
522  write_restart=lwrst)
523  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. .not.present(fld2)) then
524  CALL oasis_put_worker(var_id,kstep,pack(fld1,mask=.true.),kinfo,write_restart=lwrst)
525  else
526  WRITE(nulprt,*) subname,estr,' Wrong field array argument list in oasis_put'
527  call oasis_abort(file=__file__,line=__line__)
528  endif
529 
530  endif
531 
532  call oasis_debug_exit(subname)
533 
534  END SUBROUTINE oasis_put_r28
535 
536 !-------------------------------------------------------------------
537 !---------------------------------------------------------------------
538 
539 !> Send 8 byte real 2D bundled data
540 
541  SUBROUTINE oasis_put_r38(var_id,kstep,fld1,kinfo, &
542  fld2, fld3, fld4, fld5, write_restart)
543 
544  IMPLICIT none
545  !-------------------------------------
546  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
547  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
548  real(kind=ip_double_p) :: fld1(:,:,:) !< field data
549  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
550  real(kind=ip_double_p), optional :: fld2(:,:,:) !< higher order field data
551  real(kind=ip_double_p), optional :: fld3(:,:,:) !< higher order field data
552  real(kind=ip_double_p), optional :: fld4(:,:,:) !< higher order field data
553  real(kind=ip_double_p), optional :: fld5(:,:,:) !< higher order field data
554  logical , optional :: write_restart !< write restart now
555  !-------------------------------------
556  logical :: lwrst
557  integer(kind=ip_i4_p) :: n, size_fld1
558  character(len=*),parameter :: subname = '(oasis_put_r38)'
559  !-------------------------------------
560 
561  call oasis_debug_enter(subname)
562  kinfo = oasis_ok
563  if (.not. oasis_coupled) then
564  call oasis_debug_exit(subname)
565  return
566  endif
567 
568  if (present(write_restart)) then
569  lwrst = write_restart
570  else
571  lwrst = .false.
572  endif
573 
574  if (prism_var(var_id)%num > 1) then
575  ! treat data as 1d bundled data
576 
577  if (size(fld1,dim=3) /= prism_var(var_id)%num) then
578  write(nulprt,*) subname,estr,'called for variable ',trim(prism_var(var_id)%name)
579  write(nulprt,*) subname,estr,'expecting bundled field with num = ',prism_var(var_id)%num
580  write(nulprt,*) subname,estr,'passing in field with incorrect 3rd dim size = ',size(fld1,dim=3)
581  call oasis_abort(file=__file__,line=__line__)
582  endif
583 
584  size_fld1 = size(fld1,dim=3)
585  if (present(fld2)) then
586  if (size(fld2,dim=3) /= size_fld1) then
587  write(nulprt,*) subname,estr,'fld2 size different than fld1 size ',size_fld1,size(fld2,dim=3)
588  call oasis_abort(file=__file__,line=__line__)
589  endif
590  endif
591  if (present(fld3)) then
592  if (size(fld3,dim=3) /= size_fld1) then
593  write(nulprt,*) subname,estr,'fld3 size different than fld1 size ',size_fld1,size(fld3,dim=3)
594  call oasis_abort(file=__file__,line=__line__)
595  endif
596  endif
597  if (present(fld4)) then
598  if (size(fld4,dim=3) /= size_fld1) then
599  write(nulprt,*) subname,estr,'fld4 size different than fld1 size ',size_fld1,size(fld4,dim=3)
600  call oasis_abort(file=__file__,line=__line__)
601  endif
602  endif
603  if (present(fld5)) then
604  if (size(fld5,dim=3) /= size_fld1) then
605  write(nulprt,*) subname,estr,'fld5 size different than fld1 size ',size_fld1,size(fld5,dim=3)
606  call oasis_abort(file=__file__,line=__line__)
607  endif
608  endif
609 
610  do n = 1,prism_var(var_id)%num
611  if (present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
612  CALL oasis_put_worker(var_id,kstep,pack(fld1(:,:,n),mask=.true.),kinfo,pack(fld2(:,:,n),mask=.true.), &
613  pack(fld3(:,:,n),mask=.true.),pack(fld4(:,:,n),mask=.true.),pack(fld5(:,:,n),mask=.true.), &
614  write_restart=lwrst,varnum=n)
615  elseif (.not.present(fld5) .and. present(fld4) .and. present(fld3) .and. present(fld2)) then
616  CALL oasis_put_worker(var_id,kstep,pack(fld1(:,:,n),mask=.true.),kinfo,pack(fld2(:,:,n),mask=.true.), &
617  pack(fld3(:,:,n),mask=.true.),pack(fld4(:,:,n),mask=.true.),write_restart=lwrst,varnum=n)
618  elseif (.not.present(fld5) .and. .not.present(fld4) .and. present(fld3) .and. present(fld2)) then
619  CALL oasis_put_worker(var_id,kstep,pack(fld1(:,:,n),mask=.true.),kinfo,pack(fld2(:,:,n),mask=.true.), &
620  pack(fld3(:,:,n),mask=.true.),write_restart=lwrst,varnum=n)
621  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. present(fld2)) then
622  CALL oasis_put_worker(var_id,kstep,pack(fld1(:,:,n),mask=.true.),kinfo,pack(fld2(:,:,n),mask=.true.), &
623  write_restart=lwrst,varnum=n)
624  elseif (.not.present(fld5) .and. .not.present(fld4) .and. .not.present(fld3) .and. .not.present(fld2)) then
625  CALL oasis_put_worker(var_id,kstep,pack(fld1(:,:,n),mask=.true.),kinfo,write_restart=lwrst,varnum=n)
626  else
627  WRITE(nulprt,*) subname,estr,' Wrong field array argument list in oasis_put'
628  call oasis_abort(file=__file__,line=__line__)
629  endif
630  enddo
631 
632  else
633  WRITE(nulprt,*) subname,estr,' Dimension sizes incorrect'
634  call oasis_abort(file=__file__,line=__line__)
635 
636  endif
637 
638  call oasis_debug_exit(subname)
639 
640  END SUBROUTINE oasis_put_r38
641 
642 !-------------------------------------------------------------------
643 !---------------------------------------------------------------------
644 !> Send worker routine puts 8 byte real 1D data
645 
646  SUBROUTINE oasis_put_worker(var_id,kstep,fld1,kinfo, &
647  fld2, fld3, fld4, fld5, write_restart, varnum)
648 
649  IMPLICIT none
650  !-------------------------------------
651  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
652  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
653  real(kind=ip_double_p) :: fld1(:) !< field data
654  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
655  real(kind=ip_double_p), optional :: fld2(:) !< higher order field data
656  real(kind=ip_double_p), optional :: fld3(:) !< higher order field data
657  real(kind=ip_double_p), optional :: fld4(:) !< higher order field data
658  real(kind=ip_double_p), optional :: fld5(:) !< higher order field data
659  logical , optional :: write_restart !< write restart now
660  integer(kind=ip_i4_p) , optional :: varnum !< varnum in bundled field
661  !-------------------------------------
662  integer(kind=ip_i4_p) :: nfld,ncpl
663  integer(kind=ip_i4_p) :: ns,nsx
664  integer(kind=ip_i4_p) :: n
665  integer(kind=ip_i4_p) :: lvarnum
666  logical :: a2on, a3on, a4on, a5on
667  logical :: lwrst
668  character(len=*),parameter :: subname = '(oasis_put_worker)'
669  !-------------------------------------
670 
671  call oasis_debug_enter(subname)
672  kinfo = oasis_ok
673  if (.not. oasis_coupled) then
674  call oasis_debug_exit(subname)
675  return
676  endif
677 
678  if (.not. enddef_called) then
679  write(nulprt,*) subname,estr,'called before oasis_enddef'
680  call oasis_abort(file=__file__,line=__line__)
681  endif
682 
683  if (var_id == oasis_var_uncpl) then
684  write(nulprt,*) subname,estr,'oasis_put is called for a variable not in namcouple'
685  call oasis_abort(file=__file__,line=__line__)
686  call oasis_debug_exit(subname)
687  return
688  endif
689 
690  if (var_id < 1 .or. var_id > prism_nvar) then
691  write(nulprt,*) subname,estr,'oasis_put is called for a variable not defined'
692  call oasis_abort(file=__file__,line=__line__)
693  call oasis_debug_exit(subname)
694  return
695  endif
696 
697  if (present(write_restart)) then
698  lwrst = write_restart
699  else
700  lwrst = .false.
701  endif
702 
703  if (present(varnum)) then
704  lvarnum = varnum
705  else
706  lvarnum = 1
707  endif
708 
709  nfld = var_id
710  ncpl = prism_var(nfld)%ncpl
711 
712  if (ncpl <= 0) then
713  if (oasis_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
714  trim(prism_var(nfld)%name)
715  call oasis_debug_exit(subname)
716  return
717  endif
718 
719  ns = size(fld1,dim=1)
720 
721  a2on = .false.
722  a3on = .false.
723  a4on = .false.
724  a5on = .false.
725 
726  if (present(fld2)) then
727  a2on = .true.
728  nsx = size(fld2,dim=1)
729  if (nsx /= ns) then
730  write(nulprt,*) subname,estr,'fld2 size does not match fld ', &
731  trim(prism_var(nfld)%name)
732  call oasis_abort(file=__file__,line=__line__)
733  endif
734  endif
735 
736  if (present(fld3)) then
737  a3on = .true.
738  nsx = size(fld3,dim=1)
739  if (nsx /= ns) then
740  write(nulprt,*) subname,estr,'fld3 size does not match fld ', &
741  trim(prism_var(nfld)%name)
742  call oasis_abort(file=__file__,line=__line__)
743  endif
744  endif
745 
746  if (present(fld4)) then
747  a4on = .true.
748  nsx = size(fld4,dim=1)
749  if (nsx /= ns) then
750  write(nulprt,*) subname,estr,'fld4 size does not match fld ', &
751  trim(prism_var(nfld)%name)
752  call oasis_abort(file=__file__,line=__line__)
753  endif
754  endif
755 
756  if (present(fld5)) then
757  a5on = .true.
758  nsx = size(fld5,dim=1)
759  if (nsx /= ns) then
760  write(nulprt,*) subname,estr,'fld5 size does not match fld ', &
761  trim(prism_var(nfld)%name)
762  call oasis_abort(file=__file__,line=__line__)
763  endif
764  endif
765 
766  IF ((.NOT. a2on) .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
767  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
768  array1din=fld1,readrest=.false.,writrest=lwrst,varnum=lvarnum)
769  ELSE IF (a2on .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
770  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
771  array1din=fld1,readrest=.false.,&
772  a2on=a2on,array2=fld2,writrest=lwrst,varnum=lvarnum)
773  ELSE IF (a2on .AND. a3on .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
774  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
775  array1din= fld1,readrest=.false.,&
776  a2on=a2on,array2=fld2,&
777  a3on=a3on,array3=fld3,writrest=lwrst,varnum=lvarnum)
778  ELSE IF (a2on .AND. a3on .AND. a4on .AND. (.NOT. a5on)) THEN
779  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
780  array1din=fld1,readrest=.false.,&
781  a2on=a2on,array2=fld2,&
782  a3on=a3on,array3=fld3,&
783  a4on=a4on,array4=fld4,writrest=lwrst,varnum=lvarnum)
784  ELSE IF (a2on .AND. a3on .AND. a4on .AND. a5on) THEN
785  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
786  array1din=fld1,readrest=.false.,&
787  a2on=a2on,array2=fld2,&
788  a3on=a3on,array3=fld3,&
789  a4on=a4on,array4=fld4,&
790  a5on=a5on,array5=fld5,writrest=lwrst,varnum=lvarnum)
791  ELSE
792  WRITE(nulprt,*) subname,estr,' Wrong field array argument list in oasis_put'
793  call oasis_abort(file=__file__,line=__line__)
794  ENDIF
795 
796  call oasis_debug_exit(subname)
797 
798  END SUBROUTINE oasis_put_worker
799 
800 !-------------------------------------------------------------------
801 !---------------------------------------------------------------------
802 #ifndef __NO_4BYTE_REALS
803 
804 !> Receive 4 byte real 1D data
805 
806  SUBROUTINE oasis_get_r14(var_id,kstep,fld,kinfo)
807 
808  IMPLICIT none
809  !-------------------------------------
810  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
811  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
812  real(kind=ip_single_p), intent(inout) :: fld(:) !< field data
813  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
814  !-------------------------------------
815  integer(kind=ip_i4_p) :: ns
816  real(kind=ip_r8_p), allocatable :: array(:)
817  character(len=*),parameter :: subname = '(oasis_get_r14)'
818  !-------------------------------------
819 
820  call oasis_debug_enter(subname)
821  kinfo = oasis_ok
822  if (.not. oasis_coupled) then
823  call oasis_debug_exit(subname)
824  return
825  endif
826 
827  if (prism_var(var_id)%num > 1) then
828  write(nulprt,*) subname,estr,'called for variable ',trim(prism_var(var_id)%name)
829  write(nulprt,*) subname,estr,'expecting bundled field with num = ',prism_var(var_id)%num
830  call oasis_abort(file=__file__,line=__line__)
831  endif
832 
833  ns = size(fld,dim=1)
834  allocate(array(ns))
835 
836  call oasis_get_worker(var_id,kstep,array,kinfo)
837 
838  IF (kinfo /= oasis_ok) THEN
839  fld(:) = REAL(array(:))
840  ENDIF
841 
842  deallocate(array)
843 
844  call oasis_debug_exit(subname)
845 
846  END SUBROUTINE oasis_get_r14
847 #endif
848 
849 !---------------------------------------------------------------------
850 
851 !> Receive 8 byte real 1D data
852 
853  SUBROUTINE oasis_get_r18(var_id,kstep,fld,kinfo)
854 
855  IMPLICIT none
856  !-------------------------------------
857  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
858  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
859  real(kind=ip_r8_p) , intent(inout) :: fld(:) !< field data
860  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
861  !-------------------------------------
862  character(len=*),parameter :: subname = '(oasis_get_r18)'
863  !-------------------------------------
864 
865  call oasis_debug_enter(subname)
866  kinfo = oasis_ok
867  if (.not. oasis_coupled) then
868  call oasis_debug_exit(subname)
869  return
870  endif
871 
872  if (prism_var(var_id)%num > 1) then
873  write(nulprt,*) subname,estr,'called for variable ',trim(prism_var(var_id)%name)
874  write(nulprt,*) subname,estr,'expecting bundled field with num = ',prism_var(var_id)%num
875  call oasis_abort(file=__file__,line=__line__)
876  endif
877 
878  call oasis_get_worker(var_id,kstep,fld,kinfo)
879 
880  call oasis_debug_exit(subname)
881 
882  END SUBROUTINE oasis_get_r18
883 
884 !---------------------------------------------------------------------
885 #ifndef __NO_4BYTE_REALS
886 
887 !> Receive 4 byte real 2D data
888 
889  SUBROUTINE oasis_get_r24(var_id,kstep,fld,kinfo)
890 
891  IMPLICIT none
892  !-------------------------------------
893  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
894  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
895  real(kind=ip_single_p), intent(inout) :: fld(:,:) !< field data
896  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
897  !-------------------------------------
898  integer(kind=ip_i4_p) :: ns,nis,njs,n
899  REAL(kind=ip_r8_p), ALLOCATABLE :: array(:)
900  character(len=*),parameter :: subname = '(oasis_get_r24)'
901  !-------------------------------------
902 
903  call oasis_debug_enter(subname)
904  kinfo = oasis_ok
905  if (.not. oasis_coupled) then
906  call oasis_debug_exit(subname)
907  return
908  endif
909 
910  if (prism_var(var_id)%num > 1) then
911  ! treat as 1d bundled data
912  if (size(fld,dim=2) /= prism_var(var_id)%num) then
913  write(nulprt,*) subname,estr,'called for variable ',trim(prism_var(var_id)%name)
914  write(nulprt,*) subname,estr,'expecting bundled field with num = ',prism_var(var_id)%num
915  write(nulprt,*) subname,estr,'passing in field with incorrect 2nd dim size = ',size(fld,dim=2)
916  call oasis_abort(file=__file__,line=__line__)
917  endif
918 
919  nis = size(fld,dim=1)
920  ALLOCATE(array(nis))
921 
922  do n = 1,prism_var(var_id)%num
923  kinfo = oasis_ok
924  CALL oasis_get_worker(var_id,kstep,array,kinfo,varnum=n)
925  IF (kinfo /= oasis_ok) THEN
926  fld(:,n) = REAL(array(:))
927  ENDIF
928  enddo
929 
930  deallocate(array)
931 
932  else
933  ! treat as 2d unbundled data
934 
935  nis = size(fld,dim=1)
936  njs = size(fld,dim=2)
937  ns = nis*njs
938 
939  ALLOCATE(array(ns))
940 
941  CALL oasis_get_worker(var_id,kstep,array,kinfo)
942 
943  IF (kinfo /= oasis_ok) THEN
944  fld(:,:) = REAL(RESHAPE(array(:),SHAPE(fld)))
945  ENDIF
946 
947  deallocate(array)
948 
949  endif
950 
951  call oasis_debug_exit(subname)
952 
953  END SUBROUTINE oasis_get_r24
954 #endif
955 
956 !---------------------------------------------------------------------
957 !---------------------------------------------------------------------
958 #ifndef __NO_4BYTE_REALS
959 
960 !> Receive 4 byte real 2D bundled data
961 
962  SUBROUTINE oasis_get_r34(var_id,kstep,fld,kinfo)
963 
964  IMPLICIT none
965  !-------------------------------------
966  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
967  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
968  real(kind=ip_single_p), intent(inout) :: fld(:,:,:) !< field data
969  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
970  !-------------------------------------
971  integer(kind=ip_i4_p) :: ns,nis,njs,n
972  REAL(kind=ip_r8_p), ALLOCATABLE :: array(:)
973  character(len=*),parameter :: subname = '(oasis_get_r34)'
974  !-------------------------------------
975 
976  call oasis_debug_enter(subname)
977  kinfo = oasis_ok
978  if (.not. oasis_coupled) then
979  call oasis_debug_exit(subname)
980  return
981  endif
982 
983  if (prism_var(var_id)%num > 1) then
984  ! treat as 2d bundled data
985  if (size(fld,dim=3) /= prism_var(var_id)%num) then
986  write(nulprt,*) subname,estr,'called for variable ',trim(prism_var(var_id)%name)
987  write(nulprt,*) subname,estr,'expecting bundled field with num = ',prism_var(var_id)%num
988  write(nulprt,*) subname,estr,'passing in field with incorrect 3rd dim size = ',size(fld,dim=3)
989  call oasis_abort(file=__file__,line=__line__)
990  endif
991 
992  nis = size(fld,dim=1)
993  njs = size(fld,dim=2)
994  ns = nis*njs
995 
996  ALLOCATE(array(ns))
997 
998  do n = 1,prism_var(var_id)%num
999  kinfo = oasis_ok
1000  CALL oasis_get_worker(var_id,kstep,array,kinfo,varnum=n)
1001  IF (kinfo /= oasis_ok) THEN
1002  fld(:,:,n) = REAL(RESHAPE(array(:),SHAPE(fld(:,:,n))))
1003  ENDIF
1004  enddo
1005 
1006  deallocate(array)
1007 
1008  else
1009 
1010  WRITE(nulprt,*) subname,estr,' Dimension sizes incorrect'
1011  call oasis_abort(file=__file__,line=__line__)
1012 
1013  endif
1014 
1015  call oasis_debug_exit(subname)
1016 
1017  END SUBROUTINE oasis_get_r34
1018 #endif
1019 
1020 !---------------------------------------------------------------------
1021 
1022 !> Receive 8 byte real 2D data
1023 
1024  SUBROUTINE oasis_get_r28(var_id,kstep,fld,kinfo)
1025 
1026  IMPLICIT none
1027  !-------------------------------------
1028  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
1029  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
1030  real(kind=ip_double_p), intent(inout) :: fld(:,:) !< field data
1031  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
1032  !-------------------------------------
1033  integer(kind=ip_i4_p) :: ns,nis,njs,n
1034  REAL(kind=ip_r8_p), ALLOCATABLE :: array(:)
1035  character(len=*),parameter :: subname = '(oasis_get_r28)'
1036  !-------------------------------------
1037 
1038  call oasis_debug_enter(subname)
1039  kinfo = oasis_ok
1040  if (.not. oasis_coupled) then
1041  call oasis_debug_exit(subname)
1042  return
1043  endif
1044 
1045  if (prism_var(var_id)%num > 1) then
1046  ! treat as 1d bundled data
1047  if (size(fld,dim=2) /= prism_var(var_id)%num) then
1048  write(nulprt,*) subname,estr,'called for variable ',trim(prism_var(var_id)%name)
1049  write(nulprt,*) subname,estr,'expecting bundled field with num = ',prism_var(var_id)%num
1050  write(nulprt,*) subname,estr,'passing in field with incorrect 2nd dim size = ',size(fld,dim=2)
1051  call oasis_abort(file=__file__,line=__line__)
1052  endif
1053 
1054  nis = size(fld,dim=1)
1055  ALLOCATE(array(nis))
1056 
1057  do n = 1,prism_var(var_id)%num
1058  kinfo = oasis_ok
1059  CALL oasis_get_worker(var_id,kstep,array,kinfo,varnum=n)
1060  IF (kinfo /= oasis_ok) THEN
1061  fld(:,n) = array(:)
1062  ENDIF
1063  enddo
1064 
1065  deallocate(array)
1066 
1067  else
1068  ! treat as 2d unbundled data
1069 
1070  nis = size(fld,dim=1)
1071  njs = size(fld,dim=2)
1072  ns = nis*njs
1073 
1074  ALLOCATE(array(ns))
1075 
1076  CALL oasis_get_worker(var_id,kstep,array,kinfo)
1077 
1078  IF (kinfo /= oasis_ok) THEN
1079  fld(:,:) = reshape(array(:),shape(fld))
1080  ENDIF
1081 
1082  deallocate(array)
1083  endif
1084 
1085  call oasis_debug_exit(subname)
1086 
1087  END SUBROUTINE oasis_get_r28
1088 
1089 !-------------------------------------------------------------------
1090 !---------------------------------------------------------------------
1091 
1092 !> Receive 8 byte real 2D bundled data
1093 
1094  SUBROUTINE oasis_get_r38(var_id,kstep,fld,kinfo)
1095 
1096  IMPLICIT none
1097  !-------------------------------------
1098  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
1099  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
1100  real(kind=ip_double_p), intent(inout) :: fld(:,:,:) !< field data
1101  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
1102  !-------------------------------------
1103  integer(kind=ip_i4_p) :: ns,nis,njs,n
1104  REAL(kind=ip_r8_p), ALLOCATABLE :: array(:)
1105  character(len=*),parameter :: subname = '(oasis_get_r38)'
1106  !-------------------------------------
1107 
1108  call oasis_debug_enter(subname)
1109  kinfo = oasis_ok
1110  if (.not. oasis_coupled) then
1111  call oasis_debug_exit(subname)
1112  return
1113  endif
1114 
1115  if (prism_var(var_id)%num > 1) then
1116  ! treat as 2d bundled data
1117  if (size(fld,dim=3) /= prism_var(var_id)%num) then
1118  write(nulprt,*) subname,estr,'called for variable ',trim(prism_var(var_id)%name)
1119  write(nulprt,*) subname,estr,'expecting bundled field with num = ',prism_var(var_id)%num
1120  write(nulprt,*) subname,estr,'passing in field with incorrect 3rd dim size = ',size(fld,dim=3)
1121  call oasis_abort(file=__file__,line=__line__)
1122  endif
1123 
1124  nis = size(fld,dim=1)
1125  njs = size(fld,dim=2)
1126  ns = nis*njs
1127 
1128  ALLOCATE(array(ns))
1129 
1130  do n = 1,prism_var(var_id)%num
1131  kinfo = oasis_ok
1132  CALL oasis_get_worker(var_id,kstep,array,kinfo,varnum=n)
1133  IF (kinfo /= oasis_ok) THEN
1134  fld(:,:,n) = reshape(array(:),shape(fld(:,:,n)))
1135  ENDIF
1136  enddo
1137 
1138  deallocate(array)
1139 
1140  else
1141  WRITE(nulprt,*) subname,estr,' Dimension sizes incorrect'
1142  call oasis_abort(file=__file__,line=__line__)
1143 
1144  endif
1145 
1146  call oasis_debug_exit(subname)
1147 
1148  END SUBROUTINE oasis_get_r38
1149 
1150 !-------------------------------------------------------------------
1151 !> Receive subroutine that actually does the work on 8 byte 1D data
1152 
1153  SUBROUTINE oasis_get_worker(var_id,kstep,fld,kinfo,varnum)
1154 
1155  IMPLICIT none
1156  !-------------------------------------
1157  integer(kind=ip_i4_p) , intent(in) :: var_id !< variable id
1158  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
1159  real(kind=ip_double_p), intent(inout) :: fld(:) !< field data
1160  integer(kind=ip_i4_p) , intent(out):: kinfo !< return code
1161  integer(kind=ip_i4_p) , optional :: varnum !< variable num in bundled field
1162  !-------------------------------------
1163  integer(kind=ip_i4_p) :: nfld,ncpl
1164  integer(kind=ip_i4_p) :: lvarnum
1165  character(len=*),parameter :: subname = '(oasis_get_worker)'
1166  !-------------------------------------
1167 
1168  call oasis_debug_enter(subname)
1169  kinfo = oasis_ok
1170  if (.not. oasis_coupled) then
1171  call oasis_debug_exit(subname)
1172  return
1173  endif
1174 
1175  if (.not. enddef_called) then
1176  write(nulprt,*) subname,estr,'called before oasis_enddef'
1177  call oasis_abort(file=__file__,line=__line__)
1178  endif
1179 
1180  if (var_id == oasis_var_uncpl) then
1181  write(nulprt,*) subname,estr,'oasis_get is called for a variable not in namcouple'
1182  write(nulprt,*) subname,' BE CAREFUL NOT TO USE IT !!!!!'
1183  call oasis_abort(file=__file__,line=__line__)
1184  call oasis_debug_exit(subname)
1185  return
1186  endif
1187 
1188  if (var_id < 1 .or. var_id > prism_nvar) then
1189  write(nulprt,*) subname,estr,'oasis_get is called for a variable not defined'
1190  call oasis_abort(file=__file__,line=__line__)
1191  call oasis_debug_exit(subname)
1192  return
1193  endif
1194 
1195  if (present(varnum)) then
1196  lvarnum = varnum
1197  else
1198  lvarnum = 1
1199  endif
1200 
1201  nfld = var_id
1202  ncpl = prism_var(nfld)%ncpl
1203 
1204  if (ncpl <= 0) then
1205  if (oasis_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
1206  trim(prism_var(nfld)%name)
1207  call oasis_debug_exit(subname)
1208  return
1209  endif
1210 
1211  CALL oasis_advance_run(oasis_in,nfld,kstep,kinfo,array1dout=fld,readrest=.false.,varnum=lvarnum)
1212 
1213  call oasis_debug_exit(subname)
1214 
1215  END SUBROUTINE oasis_get_worker
1216 
1217 !-------------------------------------------------------------------
1218 
1219 END MODULE mod_oasis_getput_interface
1220 
mod_oasis_getput_interface::oasis_get_r18
subroutine oasis_get_r18(var_id, kstep, fld, kinfo)
Receive 8 byte real 1D data.
Definition: mod_oasis_getput_interface.F90:854
mod_oasis_sys
System type methods.
Definition: mod_oasis_sys.F90:4
mod_oasis_data
Provides a common location for several OASIS variables.
Definition: mod_oasis_data.F90:4
mod_oasis_parameters::oasis_ok
integer(kind=ip_intwp_p), parameter oasis_ok
Definition: mod_oasis_parameters.F90:21
mod_oasis_parameters::oasis_in
integer(kind=ip_intwp_p), parameter oasis_in
Definition: mod_oasis_parameters.F90:31
mod_oasis_data::nulprt
integer(kind=ip_intwp_p) nulprt
Definition: mod_oasis_data.F90:20
mod_oasis_getput_interface::oasis_put_r38
subroutine oasis_put_r38(var_id, kstep, fld1, kinfo, fld2, fld3, fld4, fld5, write_restart)
Send 8 byte real 2D bundled data.
Definition: mod_oasis_getput_interface.F90:543
mod_oasis_getput_interface::oasis_put_r28
subroutine oasis_put_r28(var_id, kstep, fld1, kinfo, fld2, fld3, fld4, fld5, write_restart)
Send 8 byte real 2D data.
Definition: mod_oasis_getput_interface.F90:420
mod_oasis_data::enddef_called
logical enddef_called
Definition: mod_oasis_data.F90:25
mod_oasis_sys::oasis_abort
subroutine, public oasis_abort(id_compid, cd_routine, cd_message, file, line, rcode)
OASIS abort method, publically available to users.
Definition: mod_oasis_sys.F90:44
mod_oasis_getput_interface::oasis_get_r38
subroutine oasis_get_r38(var_id, kstep, fld, kinfo)
Receive 8 byte real 2D bundled data.
Definition: mod_oasis_getput_interface.F90:1095
mod_oasis_advance::oasis_advance_run
subroutine, public oasis_advance_run(mop, varid, msec, kinfo, nff, namid, array1din, array1dout, array2dout, readrest, a2on, array2, a3on, array3, a4on, array4, a5on, array5, writrest, varnum)
Advances the OASIS coupling.
Definition: mod_oasis_advance.F90:324
mod_oasis_kinds
Defines kinds for OASIS.
Definition: mod_oasis_kinds.F90:7
mod_oasis_sys::oasis_debug_enter
subroutine, public oasis_debug_enter(string)
Used when a subroutine is entered, write info to log file at some debug level.
Definition: mod_oasis_sys.F90:209
mod_oasis_getput_interface::oasis_put_r18
subroutine oasis_put_r18(var_id, kstep, fld1, kinfo, fld2, fld3, fld4, fld5, write_restart)
Send 4 byte real 1D data.
Definition: mod_oasis_getput_interface.F90:124
mod_oasis_data::oasis_coupled
logical oasis_coupled
Definition: mod_oasis_data.F90:42
mod_oasis_getput_interface::oasis_put_r14
subroutine oasis_put_r14(var_id, kstep, fld1, kinfo, fld2, fld3, fld4, fld5, write_restart)
Send 4 byte real 1D data.
Definition: mod_oasis_getput_interface.F90:58
mod_oasis_getput_interface::oasis_get_r14
subroutine oasis_get_r14(var_id, kstep, fld, kinfo)
Receive 4 byte real 1D data.
Definition: mod_oasis_getput_interface.F90:807
mod_oasis_getput_interface::istatus
integer(kind=ip_i4_p), dimension(mpi_status_size) istatus
Definition: mod_oasis_getput_interface.F90:23
mod_oasis_getput_interface::oasis_put_r34
subroutine oasis_put_r34(var_id, kstep, fld1, kinfo, fld2, fld3, fld4, fld5, write_restart)
Send 4 byte real 2D bundled data.
Definition: mod_oasis_getput_interface.F90:314
mod_oasis_getput_interface::oasis_get_r28
subroutine oasis_get_r28(var_id, kstep, fld, kinfo)
Receive 8 byte real 2D data.
Definition: mod_oasis_getput_interface.F90:1025
mod_oasis_getput_interface::oasis_get_worker
subroutine oasis_get_worker(var_id, kstep, fld, kinfo, varnum)
Receive subroutine that actually does the work on 8 byte 1D data.
Definition: mod_oasis_getput_interface.F90:1154
mod_oasis_parameters
Defines parameters for OASIS.
Definition: mod_oasis_parameters.F90:4
mod_oasis_var
OASIS variable data and methods.
Definition: mod_oasis_var.F90:4
mod_oasis_data::oasis_debug
integer(kind=ip_i4_p) oasis_debug
Definition: mod_oasis_data.F90:21
mod_oasis_parameters::oasis_out
integer(kind=ip_intwp_p), parameter oasis_out
Definition: mod_oasis_parameters.F90:29
mod_oasis_sys::estr
character(len= *), parameter, public estr
Definition: mod_oasis_sys.F90:12
mod_oasis_getput_interface::oasis_put_worker
subroutine oasis_put_worker(var_id, kstep, fld1, kinfo, fld2, fld3, fld4, fld5, write_restart, varnum)
Send worker routine puts 8 byte real 1D data.
Definition: mod_oasis_getput_interface.F90:648
mod_oasis_getput_interface
OASIS send/receive (put/get) user interfaces.
Definition: mod_oasis_getput_interface.F90:4
mod_oasis_getput_interface::oasis_put_r24
subroutine oasis_put_r24(var_id, kstep, fld1, kinfo, fld2, fld3, fld4, fld5, write_restart)
Send 4 byte real 2D data.
Definition: mod_oasis_getput_interface.F90:190
mod_oasis_parameters::oasis_var_uncpl
integer(kind=ip_intwp_p), parameter oasis_var_uncpl
Definition: mod_oasis_parameters.F90:27
mod_oasis_advance
Advances the OASIS coupling.
Definition: mod_oasis_advance.F90:4
mod_oasis_var::prism_nvar
integer(kind=ip_intwp_p), public prism_nvar
number of variables defined
Definition: mod_oasis_var.F90:40
mod_oasis_getput_interface::oasis_get_r34
subroutine oasis_get_r34(var_id, kstep, fld, kinfo)
Receive 4 byte real 2D bundled data.
Definition: mod_oasis_getput_interface.F90:963
mod_oasis_var::prism_var
type(prism_var_type), dimension(:), pointer, public prism_var
list of defined variables
Definition: mod_oasis_var.F90:41
mod_oasis_getput_interface::oasis_get
Generic overloaded interface for data get (receive)
Definition: mod_oasis_getput_interface.F90:38
mod_oasis_sys::oasis_debug_exit
subroutine, public oasis_debug_exit(string)
Used when a subroutine is exited, write info to log file at some debug level.
Definition: mod_oasis_sys.F90:236
mod_oasis_getput_interface::oasis_put
Generic overloaded interface for data put (send)
Definition: mod_oasis_getput_interface.F90:26
mod_oasis_getput_interface::oasis_get_r24
subroutine oasis_get_r24(var_id, kstep, fld, kinfo)
Receive 4 byte real 2D data.
Definition: mod_oasis_getput_interface.F90:890
Generated on Fri Jun 29 2018 20:52:28 for Oasis3-MCT by   doxygen 1.8.13