Oasis3-MCT
 All Classes Files Functions Variables Macros Pages
mod_oasis_getput_interface.F90
Go to the documentation of this file.
1 
2 !> OASIS send/receive (put/get) user interfaces
3 
5 !---------------------------------------------------------------------
6 
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 #endif
31  module procedure oasis_put_r18
32  module procedure oasis_put_r28
33  end interface
34 
35 !> Generic overloaded interface for data get (receive)
36  interface oasis_get
37 #ifndef __NO_4BYTE_REALS
38  module procedure oasis_get_r14
39  module procedure oasis_get_r24
40 #endif
41  module procedure oasis_get_r18
42  module procedure oasis_get_r28
43  end interface
44 
45 !---------------------------------------------------------------------
46 contains
47 !---------------------------------------------------------------------
48 #ifndef __NO_4BYTE_REALS
49 
50 !> Send 4 byte real 1D data
51 
52  SUBROUTINE oasis_put_r14(id_port_id,kstep,fld1,kinfo, &
53  fld2, fld3, fld4, fld5)
54 
55  IMPLICIT none
56  !-------------------------------------
57  integer(kind=ip_i4_p) , intent(in) :: id_port_id !< variable id
58  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
59  real(kind=ip_single_p) :: fld1(:) !< field data
60  integer(kind=ip_i4_p) , intent(out), optional :: kinfo !< return code
61  real(kind=ip_single_p), optional :: fld2(:) !< higher order field data
62  real(kind=ip_single_p), optional :: fld3(:) !< higher order field data
63  real(kind=ip_single_p), optional :: fld4(:) !< higher order field data
64  real(kind=ip_single_p), optional :: fld5(:) !< higher order field data
65  !-------------------------------------
66  integer(kind=ip_i4_p) :: nfld,ncpl
67  integer(kind=ip_i4_p) :: ns,nsx
68  integer(kind=ip_i4_p) :: n
69  logical :: a2on, a3on, a4on, a5on
70  character(len=*),parameter :: subname = '(oasis_put_r14)'
71  !-------------------------------------
72 
73  call oasis_debug_enter(subname)
74  kinfo = oasis_ok
75  if (.not. oasis_coupled) then
76  call oasis_debug_exit(subname)
77  return
78  endif
79 
80  if (.not. enddef_called) then
81  write(nulprt,*) subname,estr,'called before oasis_enddef'
82  call oasis_abort()
83  endif
84 
85  if (id_port_id == oasis_var_uncpl) then
86  write(nulprt,*) subname,estr,'oasis_put is called for a variable not in namcouple'
87  call oasis_abort()
88  call oasis_debug_exit(subname)
89  return
90  endif
91 
92  if (id_port_id < 1 .or. id_port_id > prism_nvar) then
93  write(nulprt,*) subname,estr,'oasis_put is called for a variable not defined'
94  call oasis_abort()
95  call oasis_debug_exit(subname)
96  return
97  endif
98 
99  nfld = id_port_id
100  ncpl = prism_var(nfld)%ncpl
101 
102  if (ncpl <= 0) then
103  if (oasis_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
104  trim(prism_var(nfld)%name)
105  call oasis_debug_exit(subname)
106  return
107  endif
108 
109  ns = size(fld1,dim=1)
110 
111  a2on = .false.
112  a3on = .false.
113  a4on = .false.
114  a5on = .false.
115 
116  if (present(fld2)) then
117  a2on = .true.
118  nsx = size(fld2,dim=1)
119  if (nsx /= ns) then
120  write(nulprt,*) subname,estr,'fld2 size does not match fld1 ', &
121  trim(prism_var(nfld)%name)
122  CALL oasis_abort()
123  endif
124  endif
125 
126  if (present(fld3)) then
127  a3on = .true.
128  nsx = size(fld3,dim=1)
129  if (nsx /= ns) then
130  write(nulprt,*) subname,estr,'fld3 size does not match fld1 ', &
131  trim(prism_var(nfld)%name)
132  CALL oasis_abort()
133  endif
134  endif
135 
136  if (present(fld4)) then
137  a4on = .true.
138  nsx = size(fld4,dim=1)
139  if (nsx /= ns) then
140  write(nulprt,*) subname,estr,'fld4 size does not match fld1 ', &
141  trim(prism_var(nfld)%name)
142  CALL oasis_abort()
143  endif
144  endif
145 
146  if (present(fld5)) then
147  a5on = .true.
148  nsx = size(fld5,dim=1)
149  if (nsx /= ns) then
150  write(nulprt,*) subname,estr,'fld5 size does not match fld1 ', &
151  trim(prism_var(nfld)%name)
152  CALL oasis_abort()
153  endif
154  endif
155 
156 
157  IF ((.NOT. a2on) .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
158  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
159  array1din= dble(fld1),readrest=.false.)
160  ELSE IF (a2on .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
161  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
162  array1din= dble(fld1),readrest=.false.,&
163  a2on=a2on,array2=dble(fld2))
164  ELSE IF (a2on .AND. a3on .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
165  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
166  array1din= dble(fld1),readrest=.false.,&
167  a2on=a2on,array2=dble(fld2),&
168  a3on=a3on,array3=dble(fld3))
169  ELSE IF (a2on .AND. a3on .AND. a4on .AND. (.NOT. a5on)) THEN
170  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
171  array1din= dble(fld1),readrest=.false.,&
172  a2on=a2on,array2=dble(fld2),&
173  a3on=a3on,array3=dble(fld3),&
174  a4on=a4on,array4=dble(fld4))
175  ELSE IF (a2on .AND. a3on .AND. a4on .AND. a5on) THEN
176  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
177  array1din= dble(fld1),readrest=.false.,&
178  a2on=a2on,array2=dble(fld2),&
179  a3on=a3on,array3=dble(fld3),&
180  a4on=a4on,array4=dble(fld4),&
181  a5on=a5on,array5=dble(fld5))
182  ELSE
183  WRITE(nulprt,*) 'Wrong field array argument list in oasis_put'
184  CALL oasis_flush(nulprt)
185  ENDIF
186 
187  call oasis_debug_exit(subname)
188 
189  END SUBROUTINE oasis_put_r14
190 #endif
191 
192 !-------------------------------------------------------------------
193 !---------------------------------------------------------------------
194 
195 !> Send 8 byte real 1D data
196 
197  SUBROUTINE oasis_put_r18(id_port_id,kstep,fld1,kinfo, &
198  fld2, fld3, fld4, fld5)
199 
200  IMPLICIT none
201  !-------------------------------------
202  integer(kind=ip_i4_p) , intent(in) :: id_port_id !< variable id
203  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
204  real(kind=ip_double_p) :: fld1(:) !< field data
205  integer(kind=ip_i4_p) , intent(out), optional :: kinfo !< return code
206  real(kind=ip_double_p), optional :: fld2(:) !< higher order field data
207  real(kind=ip_double_p), optional :: fld3(:) !< higher order field data
208  real(kind=ip_double_p), optional :: fld4(:) !< higher order field data
209  real(kind=ip_double_p), optional :: fld5(:) !< higher order field data
210  !-------------------------------------
211  integer(kind=ip_i4_p) :: nfld,ncpl
212  integer(kind=ip_i4_p) :: ns,nsx
213  integer(kind=ip_i4_p) :: n
214  logical :: a2on, a3on, a4on, a5on
215  character(len=*),parameter :: subname = '(oasis_put_r18)'
216  !-------------------------------------
217 
218  call oasis_debug_enter(subname)
219  kinfo = oasis_ok
220  if (.not. oasis_coupled) then
221  call oasis_debug_exit(subname)
222  return
223  endif
224 
225  if (.not. enddef_called) then
226  write(nulprt,*) subname,estr,'called before oasis_enddef'
227  call oasis_abort()
228  endif
229 
230  if (id_port_id == oasis_var_uncpl) then
231  write(nulprt,*) subname,estr,'oasis_put is called for a variable not in namcouple'
232  call oasis_abort()
233  call oasis_debug_exit(subname)
234  return
235  endif
236 
237  if (id_port_id < 1 .or. id_port_id > prism_nvar) then
238  write(nulprt,*) subname,estr,'oasis_put is called for a variable not defined'
239  call oasis_abort()
240  call oasis_debug_exit(subname)
241  return
242  endif
243 
244  nfld = id_port_id
245  ncpl = prism_var(nfld)%ncpl
246 
247  if (ncpl <= 0) then
248  if (oasis_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
249  trim(prism_var(nfld)%name)
250  call oasis_debug_exit(subname)
251  return
252  endif
253 
254  ns = size(fld1,dim=1)
255 
256  a2on = .false.
257  a3on = .false.
258  a4on = .false.
259  a5on = .false.
260 
261  if (present(fld2)) then
262  a2on = .true.
263  nsx = size(fld2,dim=1)
264  if (nsx /= ns) then
265  write(nulprt,*) subname,estr,'fld2 size does not match fld ', &
266  trim(prism_var(nfld)%name)
267  CALL oasis_abort()
268  endif
269  endif
270 
271  if (present(fld3)) then
272  a3on = .true.
273  nsx = size(fld3,dim=1)
274  if (nsx /= ns) then
275  write(nulprt,*) subname,estr,'fld3 size does not match fld ', &
276  trim(prism_var(nfld)%name)
277  CALL oasis_abort()
278  endif
279  endif
280 
281  if (present(fld4)) then
282  a4on = .true.
283  nsx = size(fld4,dim=1)
284  if (nsx /= ns) then
285  write(nulprt,*) subname,estr,'fld4 size does not match fld ', &
286  trim(prism_var(nfld)%name)
287  CALL oasis_abort()
288  endif
289  endif
290 
291  if (present(fld5)) then
292  a5on = .true.
293  nsx = size(fld5,dim=1)
294  if (nsx /= ns) then
295  write(nulprt,*) subname,estr,'fld5 size does not match fld ', &
296  trim(prism_var(nfld)%name)
297  CALL oasis_abort()
298  endif
299  endif
300 
301  IF ((.NOT. a2on) .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
302  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
303  array1din=fld1,readrest=.false.)
304  ELSE IF (a2on .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
305  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
306  array1din=fld1,readrest=.false.,&
307  a2on=a2on,array2=fld2)
308  ELSE IF (a2on .AND. a3on .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
309  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
310  array1din= fld1,readrest=.false.,&
311  a2on=a2on,array2=fld2,&
312  a3on=a3on,array3=fld3)
313  ELSE IF (a2on .AND. a3on .AND. a4on .AND. (.NOT. a5on)) THEN
314  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
315  array1din=fld1,readrest=.false.,&
316  a2on=a2on,array2=fld2,&
317  a3on=a3on,array3=fld3,&
318  a4on=a4on,array4=fld4)
319  ELSE IF (a2on .AND. a3on .AND. a4on .AND. a5on) THEN
320  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
321  array1din=fld1,readrest=.false.,&
322  a2on=a2on,array2=fld2,&
323  a3on=a3on,array3=fld3,&
324  a4on=a4on,array4=fld4,&
325  a5on=a5on,array5=fld5)
326  ELSE
327  WRITE(nulprt,*) 'Wrong field array argument list in oasis_put'
328  CALL oasis_flush(nulprt)
329  ENDIF
330 
331  call oasis_debug_exit(subname)
332 
333  END SUBROUTINE oasis_put_r18
334 
335 !-------------------------------------------------------------------
336 !---------------------------------------------------------------------
337 #ifndef __NO_4BYTE_REALS
338 
339 !> Send 4 byte real 2D data
340 
341  SUBROUTINE oasis_put_r24(id_port_id,kstep,fld1,kinfo, &
342  fld2, fld3, fld4, fld5)
343 
344  IMPLICIT none
345  !-------------------------------------
346  integer(kind=ip_i4_p) , intent(in) :: id_port_id !< variable id
347  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
348  real(kind=ip_single_p) :: fld1(:,:) !< field data
349  integer(kind=ip_i4_p) , intent(out), optional :: kinfo !< return code
350  real(kind=ip_single_p), optional :: fld2(:,:) !< higher order field data
351  real(kind=ip_single_p), optional :: fld3(:,:) !< higher order field data
352  real(kind=ip_single_p), optional :: fld4(:,:) !< higher order field data
353  real(kind=ip_single_p), optional :: fld5(:,:) !< higher order field data
354  !-------------------------------------
355  integer(kind=ip_i4_p) :: nfld,ncpl
356  integer(kind=ip_i4_p) :: ns,nis,njs,nisx,njsx
357  integer(kind=ip_i4_p) :: n,ni,nj
358  logical :: a2on, a3on, a4on, a5on
359  character(len=*),parameter :: subname = '(oasis_put_r24)'
360  !-------------------------------------
361 
362  call oasis_debug_enter(subname)
363  kinfo = oasis_ok
364  if (.not. oasis_coupled) then
365  call oasis_debug_exit(subname)
366  return
367  endif
368 
369  if (.not. enddef_called) then
370  write(nulprt,*) subname,estr,'called before oasis_enddef'
371  call oasis_abort()
372  endif
373 
374  if (id_port_id == oasis_var_uncpl) then
375  write(nulprt,*) subname,estr,'oasis_put is called for a variable not in namcouple'
376  call oasis_abort()
377  call oasis_debug_exit(subname)
378  return
379  endif
380 
381  if (id_port_id < 1 .or. id_port_id > prism_nvar) then
382  write(nulprt,*) subname,estr,'oasis_put is called for a variable not defined'
383  call oasis_abort()
384  call oasis_debug_exit(subname)
385  return
386  endif
387 
388  nfld = id_port_id
389  ncpl = prism_var(nfld)%ncpl
390 
391  if (ncpl <= 0) then
392  if (oasis_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
393  trim(prism_var(nfld)%name)
394  call oasis_debug_exit(subname)
395  return
396  endif
397 
398  nis = size(fld1,dim=1)
399  njs = size(fld1,dim=2)
400  ns = nis*njs
401 
402  a2on = .false.
403  a3on = .false.
404  a4on = .false.
405  a5on = .false.
406 
407  if (present(fld2)) then
408  a2on = .true.
409  nisx = size(fld2,dim=1)
410  njsx = size(fld2,dim=2)
411  if (nisx /= nis .or. njsx /= njs) then
412  write(nulprt,*) subname,estr,'fld2 size does not match fld ', &
413  trim(prism_var(nfld)%name)
414  CALL oasis_abort()
415  endif
416  endif
417 
418  if (present(fld3)) then
419  a3on = .true.
420  nisx = size(fld3,dim=1)
421  njsx = size(fld3,dim=2)
422  if (nisx /= nis .or. njsx /= njs) then
423  write(nulprt,*) subname,estr,'fld3 size does not match fld ', &
424  trim(prism_var(nfld)%name)
425  CALL oasis_abort()
426  endif
427  endif
428 
429  if (present(fld4)) then
430  a4on = .true.
431  nisx = size(fld4,dim=1)
432  njsx = size(fld4,dim=2)
433  if (nisx /= nis .or. njsx /= njs) then
434  write(nulprt,*) subname,estr,'fld4 size does not match fld ', &
435  trim(prism_var(nfld)%name)
436  CALL oasis_abort()
437  endif
438  endif
439 
440  if (present(fld5)) then
441  a5on = .true.
442  nisx = size(fld5,dim=1)
443  njsx = size(fld5,dim=2)
444  if (nisx /= nis .or. njsx /= njs) then
445  write(nulprt,*) subname,estr,'fld5 size does not match fld ', &
446  trim(prism_var(nfld)%name)
447  CALL oasis_abort()
448  endif
449  endif
450 
451 
452  IF ((.NOT. a2on) .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
453  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
454  array1din= dble(pack(fld1, mask= .true.)),readrest=.false.)
455  ELSE IF (a2on .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
456  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
457  array1din= dble(pack(fld1, mask= .true.)),readrest=.false.,&
458  a2on=a2on,array2=dble(pack(fld2, mask= .true.)))
459  ELSE IF (a2on .AND. a3on .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
460  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
461  array1din= dble(pack(fld1, mask= .true.)),readrest=.false.,&
462  a2on=a2on,array2=dble(pack(fld2, mask= .true.)),&
463  a3on=a3on,array3=dble(pack(fld3, mask= .true.)))
464  ELSE IF (a2on .AND. a3on .AND. a4on .AND. (.NOT. a5on)) THEN
465  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
466  array1din= dble(pack(fld1, mask= .true.)),readrest=.false.,&
467  a2on=a2on,array2=dble(pack(fld2, mask= .true.)),&
468  a3on=a3on,array3=dble(pack(fld3, mask= .true.)),&
469  a4on=a4on,array4=dble(pack(fld4, mask= .true.)))
470  ELSE IF (a2on .AND. a3on .AND. a4on .AND. a5on) THEN
471  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
472  array1din= dble(pack(fld1, mask= .true.)),readrest=.false.,&
473  a2on=a2on,array2=dble(pack(fld2, mask= .true.)),&
474  a3on=a3on,array3=dble(pack(fld3, mask= .true.)),&
475  a4on=a4on,array4=dble(pack(fld4, mask= .true.)),&
476  a5on=a5on,array5=dble(pack(fld5, mask= .true.)))
477  ELSE
478  WRITE(nulprt,*) 'Wrong field array argument list in oasis_put'
479  CALL oasis_flush(nulprt)
480  ENDIF
481 
482  call oasis_debug_exit(subname)
483 
484  END SUBROUTINE oasis_put_r24
485 #endif
486 
487 !-------------------------------------------------------------------
488 !---------------------------------------------------------------------
489 
490 !> Send 8 byte real 2D data
491 
492  SUBROUTINE oasis_put_r28(id_port_id,kstep,fld1,kinfo, &
493  fld2, fld3, fld4, fld5)
494 
495  IMPLICIT none
496  !-------------------------------------
497  integer(kind=ip_i4_p) , intent(in) :: id_port_id !< variable id
498  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
499  real(kind=ip_double_p) :: fld1(:,:) !< field data
500  integer(kind=ip_i4_p) , intent(out), optional :: kinfo !< return code
501  real(kind=ip_double_p), optional :: fld2(:,:) !< higher order field data
502  real(kind=ip_double_p), optional :: fld3(:,:) !< higher order field data
503  real(kind=ip_double_p), optional :: fld4(:,:) !< higher order field data
504  real(kind=ip_double_p), optional :: fld5(:,:) !< higher order field data
505  !-------------------------------------
506  integer(kind=ip_i4_p) :: nfld,ncpl
507  integer(kind=ip_i4_p) :: ns,nis,njs,nisx,njsx
508  integer(kind=ip_i4_p) :: n,ni,nj
509  logical :: a2on, a3on, a4on, a5on
510  character(len=*),parameter :: subname = '(oasis_put_r28)'
511  !-------------------------------------
512 
513  call oasis_debug_enter(subname)
514  kinfo = oasis_ok
515  if (.not. oasis_coupled) then
516  call oasis_debug_exit(subname)
517  return
518  endif
519 
520  if (.not. enddef_called) then
521  write(nulprt,*) subname,estr,'called before oasis_enddef'
522  call oasis_abort()
523  endif
524 
525  if (id_port_id == oasis_var_uncpl) then
526  write(nulprt,*) subname,estr,'oasis_put is called for a variable not in namcouple'
527  call oasis_abort()
528  call oasis_debug_exit(subname)
529  return
530  endif
531 
532  if (id_port_id < 1 .or. id_port_id > prism_nvar) then
533  write(nulprt,*) subname,estr,'oasis_put is called for a variable not defined'
534  call oasis_abort()
535  call oasis_debug_exit(subname)
536  return
537  endif
538 
539  nfld = id_port_id
540  ncpl = prism_var(nfld)%ncpl
541 
542  if (ncpl <= 0) then
543  if (oasis_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
544  trim(prism_var(nfld)%name)
545  call oasis_debug_exit(subname)
546  return
547  endif
548 
549  nis = size(fld1,dim=1)
550  njs = size(fld1,dim=2)
551  ns = nis*njs
552 
553  a2on = .false.
554  a3on = .false.
555  a4on = .false.
556  a5on = .false.
557 
558  if (present(fld2)) then
559  a2on = .true.
560  nisx = size(fld2,dim=1)
561  njsx = size(fld2,dim=2)
562  if (nisx /= nis .or. njsx /= njs) then
563  write(nulprt,*) subname,estr,'fld2 size does not match fld ', &
564  trim(prism_var(nfld)%name)
565  CALL oasis_abort()
566  endif
567  endif
568 
569  if (present(fld3)) then
570  a3on = .true.
571  nisx = size(fld3,dim=1)
572  njsx = size(fld3,dim=2)
573  if (nisx /= nis .or. njsx /= njs) then
574  write(nulprt,*) subname,estr,'fld3 size does not match fld ', &
575  trim(prism_var(nfld)%name)
576  CALL oasis_abort()
577  endif
578  endif
579 
580  if (present(fld4)) then
581  a4on = .true.
582  nisx = size(fld4,dim=1)
583  njsx = size(fld4,dim=2)
584  if (nisx /= nis .or. njsx /= njs) then
585  write(nulprt,*) subname,estr,'fld4 size does not match fld ', &
586  trim(prism_var(nfld)%name)
587  CALL oasis_abort()
588  endif
589  endif
590 
591  if (present(fld5)) then
592  a5on = .true.
593  nisx = size(fld5,dim=1)
594  njsx = size(fld5,dim=2)
595  if (nisx /= nis .or. njsx /= njs) then
596  write(nulprt,*) subname,estr,'fld5 size does not match fld ', &
597  trim(prism_var(nfld)%name)
598  CALL oasis_abort()
599  endif
600  endif
601 
602 
603  IF ((.NOT. a2on) .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
604  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo, &
605  array1din= (pack(fld1, mask= .true.)),readrest=.false.)
606  ELSE IF (a2on .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
607  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
608  array1din= (pack(fld1, mask= .true.)),readrest=.false.,&
609  a2on=a2on,array2=(pack(fld2, mask= .true.)))
610  ELSE IF (a2on .AND. a3on .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
611  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
612  array1din= (pack(fld1, mask= .true.)),readrest=.false.,&
613  a2on=a2on,array2=(pack(fld2, mask= .true.)),&
614  a3on=a3on,array3=(pack(fld3, mask= .true.)))
615  ELSE IF (a2on .AND. a3on .AND. a4on .AND. (.NOT. a5on)) THEN
616  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
617  array1din= (pack(fld1, mask= .true.)),readrest=.false.,&
618  a2on=a2on,array2=(pack(fld2, mask= .true.)),&
619  a3on=a3on,array3=(pack(fld3, mask= .true.)),&
620  a4on=a4on,array4=(pack(fld4, mask= .true.)))
621  ELSE IF (a2on .AND. a3on .AND. a4on .AND. a5on) THEN
622  CALL oasis_advance_run(oasis_out,nfld,kstep,kinfo,&
623  array1din= (pack(fld1, mask= .true.)),readrest=.false.,&
624  a2on=a2on,array2=(pack(fld2, mask= .true.)),&
625  a3on=a3on,array3=(pack(fld3, mask= .true.)),&
626  a4on=a4on,array4=(pack(fld4, mask= .true.)),&
627  a5on=a5on,array5=(pack(fld5, mask= .true.)))
628  ELSE
629  WRITE(nulprt,*) 'Wrong field array argument list in oasis_put'
630  CALL oasis_flush(nulprt)
631  ENDIF
632 
633  call oasis_debug_exit(subname)
634 
635  END SUBROUTINE oasis_put_r28
636 
637 !-------------------------------------------------------------------
638 !---------------------------------------------------------------------
639 #ifndef __NO_4BYTE_REALS
640 
641 !> Receive 4 byte real 1D data
642 
643  SUBROUTINE oasis_get_r14(id_port_id,kstep,rd_field,kinfo)
644 
645  IMPLICIT none
646  !-------------------------------------
647  integer(kind=ip_i4_p) , intent(in) :: id_port_id !< variable id
648  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
649  real(kind=ip_single_p), intent(inout) :: rd_field(:) !< field data
650  integer(kind=ip_i4_p) , intent(out), optional :: kinfo !< return code
651  !-------------------------------------
652  integer(kind=ip_i4_p) :: nfld,ncpl
653  integer(kind=ip_i4_p) :: ns,nis,njs
654  integer(kind=ip_i4_p) :: n,ni,nj
655  real(kind=ip_r8_p), allocatable :: array(:)
656  character(len=*),parameter :: subname = '(oasis_get_r14)'
657  !-------------------------------------
658 
659  call oasis_debug_enter(subname)
660  kinfo = oasis_ok
661  if (.not. oasis_coupled) then
662  call oasis_debug_exit(subname)
663  return
664  endif
665 
666  if (.not. enddef_called) then
667  write(nulprt,*) subname,estr,'called before oasis_enddef'
668  call oasis_abort()
669  endif
670 
671  if (id_port_id == oasis_var_uncpl) then
672  write(nulprt,*) subname,estr,'oasis_get is called for a variable not in namcouple'
673  write(nulprt,*) subname,' BE CAREFUL NOT TO USE IT !!!!!'
674  call oasis_abort()
675  call oasis_debug_exit(subname)
676  return
677  endif
678 
679  if (id_port_id < 1 .or. id_port_id > prism_nvar) then
680  write(nulprt,*) subname,estr,'oasis_get is called for a variable not defined'
681  call oasis_abort()
682  call oasis_debug_exit(subname)
683  return
684  endif
685 
686  nfld = id_port_id
687  ncpl = prism_var(nfld)%ncpl
688 
689  if (ncpl <= 0) then
690  if (oasis_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
691  trim(prism_var(nfld)%name)
692  call oasis_debug_exit(subname)
693  return
694  endif
695 
696  ns = size(rd_field,dim=1)
697 
698  allocate(array(ns))
699 
700  CALL oasis_advance_run(oasis_in,nfld,kstep,kinfo,array1dout=array,readrest=.false.)
701 
702  IF (kinfo /= oasis_ok) THEN
703  rd_field(:) = REAL(array(:))
704  ENDIF
705 
706  deallocate(array)
707  call oasis_debug_exit(subname)
708 
709  END SUBROUTINE oasis_get_r14
710 #endif
711 
712 !---------------------------------------------------------------------
713 
714 !> Receive 8 byte real 1D data
715 
716  SUBROUTINE oasis_get_r18(id_port_id,kstep,rd_field,kinfo)
717 
718  IMPLICIT none
719  !-------------------------------------
720  integer(kind=ip_i4_p) , intent(in) :: id_port_id !< variable id
721  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
722  real(kind=ip_double_p), intent(inout) :: rd_field(:) !< field data
723  integer(kind=ip_i4_p) , intent(out), optional :: kinfo !< return code
724  !-------------------------------------
725  integer(kind=ip_i4_p) :: nfld,ncpl
726  integer(kind=ip_i4_p) :: ns,nis,njs
727  integer(kind=ip_i4_p) :: n,ni,nj
728  character(len=*),parameter :: subname = '(oasis_get_r18)'
729  !-------------------------------------
730 
731  call oasis_debug_enter(subname)
732  kinfo = oasis_ok
733  if (.not. oasis_coupled) then
734  call oasis_debug_exit(subname)
735  return
736  endif
737 
738  if (.not. enddef_called) then
739  write(nulprt,*) subname,estr,'called before oasis_enddef'
740  call oasis_abort()
741  endif
742 
743  if (id_port_id == oasis_var_uncpl) then
744  write(nulprt,*) subname,estr,'oasis_get is called for a variable not in namcouple'
745  write(nulprt,*) subname,' BE CAREFUL NOT TO USE IT !!!!!'
746  call oasis_abort()
747  call oasis_debug_exit(subname)
748  return
749  endif
750 
751  if (id_port_id < 1 .or. id_port_id > prism_nvar) then
752  write(nulprt,*) subname,estr,'oasis_get is called for a variable not defined'
753  call oasis_abort()
754  call oasis_debug_exit(subname)
755  return
756  endif
757 
758  nfld = id_port_id
759  ncpl = prism_var(nfld)%ncpl
760 
761  if (ncpl <= 0) then
762  if (oasis_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
763  trim(prism_var(nfld)%name)
764  call oasis_debug_exit(subname)
765  return
766  endif
767 
768  CALL oasis_advance_run(oasis_in,nfld,kstep,kinfo,array1dout=rd_field,readrest=.false.)
769 
770  call oasis_debug_exit(subname)
771 
772  END SUBROUTINE oasis_get_r18
773 
774 !---------------------------------------------------------------------
775 #ifndef __NO_4BYTE_REALS
776 
777 !> Receive 4 byte real 2D data
778 
779  SUBROUTINE oasis_get_r24(id_port_id,kstep,rd_field,kinfo)
780 
781  IMPLICIT none
782  !-------------------------------------
783  integer(kind=ip_i4_p) , intent(in) :: id_port_id !< variable id
784  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
785  real(kind=ip_single_p), intent(inout) :: rd_field(:,:) !< field data
786  integer(kind=ip_i4_p) , intent(out), optional :: kinfo !< return code
787  !-------------------------------------
788  integer(kind=ip_i4_p) :: nfld,ncpl
789  integer(kind=ip_i4_p) :: ns,nis,njs
790  integer(kind=ip_i4_p) :: n,ni,nj
791  REAL(kind=ip_r8_p), ALLOCATABLE :: array(:,:)
792  character(len=*),parameter :: subname = '(oasis_get_r24)'
793  !-------------------------------------
794 
795  call oasis_debug_enter(subname)
796  kinfo = oasis_ok
797  if (.not. oasis_coupled) then
798  call oasis_debug_exit(subname)
799  return
800  endif
801 
802  if (.not. enddef_called) then
803  write(nulprt,*) subname,estr,'called before oasis_enddef'
804  call oasis_abort()
805  endif
806 
807  if (id_port_id == oasis_var_uncpl) then
808  write(nulprt,*) subname,estr,'oasis_get is called for a variable not in namcouple'
809  write(nulprt,*) subname,' BE CAREFUL NOT TO USE IT !!!!!'
810  call oasis_abort()
811  call oasis_debug_exit(subname)
812  return
813  endif
814 
815  if (id_port_id < 1 .or. id_port_id > prism_nvar) then
816  write(nulprt,*) subname,estr,'oasis_get is called for a variable not defined'
817  call oasis_abort()
818  call oasis_debug_exit(subname)
819  return
820  endif
821 
822  nfld = id_port_id
823  ncpl = prism_var(nfld)%ncpl
824 
825  if (ncpl <= 0) then
826  if (oasis_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
827  trim(prism_var(nfld)%name)
828  call oasis_debug_exit(subname)
829  return
830  endif
831 
832  nis = size(rd_field,dim=1)
833  njs = size(rd_field,dim=2)
834  ns = nis*njs
835 
836  ALLOCATE(array(nis,njs))
837 
838  CALL oasis_advance_run(oasis_in,nfld,kstep,kinfo,array2dout=array,readrest=.false.)
839 
840  IF (kinfo /= oasis_ok) THEN
841  rd_field(:,:) = REAL(array(:,:))
842  ENDIF
843 
844  deallocate(array)
845  call oasis_debug_exit(subname)
846 
847  END SUBROUTINE oasis_get_r24
848 #endif
849 
850 !---------------------------------------------------------------------
851 
852 !> Receive 8 byte real 2D data
853 
854  SUBROUTINE oasis_get_r28(id_port_id,kstep,rd_field,kinfo)
855 
856  IMPLICIT none
857  !-------------------------------------
858  integer(kind=ip_i4_p) , intent(in) :: id_port_id !< variable id
859  integer(kind=ip_i4_p) , intent(in) :: kstep !< model time in seconds
860  real(kind=ip_double_p), intent(inout) :: rd_field(:,:) !< field data
861  integer(kind=ip_i4_p) , intent(out), optional :: kinfo !< return code
862  !-------------------------------------
863  integer(kind=ip_i4_p) :: nfld,ncpl
864  integer(kind=ip_i4_p) :: ns,nis,njs
865  integer(kind=ip_i4_p) :: n,ni,nj
866  character(len=*),parameter :: subname = '(oasis_get_r28)'
867  !-------------------------------------
868 
869  call oasis_debug_enter(subname)
870  kinfo = oasis_ok
871  if (.not. oasis_coupled) then
872  call oasis_debug_exit(subname)
873  return
874  endif
875 
876  if (.not. enddef_called) then
877  write(nulprt,*) subname,estr,'called before oasis_enddef'
878  call oasis_abort()
879  endif
880 
881  if (id_port_id == oasis_var_uncpl) then
882  write(nulprt,*) subname,estr,'oasis_get is called for a variable not in namcouple'
883  write(nulprt,*) subname,' BE CAREFUL NOT TO USE IT !!!!!'
884  call oasis_abort()
885  call oasis_debug_exit(subname)
886  return
887  endif
888 
889  if (id_port_id < 1 .or. id_port_id > prism_nvar) then
890  write(nulprt,*) subname,estr,'oasis_get is called for a variable not defined'
891  call oasis_abort()
892  call oasis_debug_exit(subname)
893  return
894  endif
895 
896  nfld = id_port_id
897  ncpl = prism_var(nfld)%ncpl
898 
899  if (ncpl <= 0) then
900  if (oasis_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
901  trim(prism_var(nfld)%name)
902  call oasis_debug_exit(subname)
903  return
904  endif
905 
906  CALL oasis_advance_run(oasis_in,nfld,kstep,kinfo,array2dout=rd_field,readrest=.false.)
907 
908  call oasis_debug_exit(subname)
909 
910  END SUBROUTINE oasis_get_r28
911 
912 !-------------------------------------------------------------------
913 
915 
subroutine oasis_get_r18(id_port_id, kstep, rd_field, kinfo)
Receive 8 byte real 1D data.
subroutine, public oasis_debug_exit(string)
Used when a subroutine is exited, write info to log file at some debug level.
System type methods.
Advances the OASIS coupling.
subroutine oasis_put_r28(id_port_id, kstep, fld1, kinfo, fld2, fld3, fld4, fld5)
Send 8 byte real 2D data.
subroutine, public oasis_advance_run(mop, varid, msec, kinfo, nff, namid, array1din, array1dout, array2dout, readrest, a2on, array2, a3on, array3, a4on, array4, a5on, array5)
Advances the OASIS coupling.
Provides a common location for several OASIS variables.
subroutine, public oasis_debug_enter(string)
Used when a subroutine is entered, write info to log file at some debug level.
Defines kinds for OASIS.
subroutine, public oasis_flush(nu)
Flushes output to file.
subroutine oasis_get_r14(id_port_id, kstep, rd_field, kinfo)
Receive 4 byte real 1D data.
subroutine oasis_put_r14(id_port_id, kstep, fld1, kinfo, fld2, fld3, fld4, fld5)
Send 4 byte real 1D data.
subroutine, public oasis_abort(id_compid, cd_routine, cd_message)
OASIS abort method, publically available to users.
subroutine oasis_get_r24(id_port_id, kstep, rd_field, kinfo)
Receive 4 byte real 2D data.
subroutine oasis_put_r18(id_port_id, kstep, fld1, kinfo, fld2, fld3, fld4, fld5)
Send 8 byte real 1D data.
subroutine oasis_get_r28(id_port_id, kstep, rd_field, kinfo)
Receive 8 byte real 2D data.
Generic overloaded interface for data get (receive)
OASIS variable data and methods.
Defines parameters for OASIS.
OASIS send/receive (put/get) user interfaces.
Generic overloaded interface for data put (send)
subroutine oasis_put_r24(id_port_id, kstep, fld1, kinfo, fld2, fld3, fld4, fld5)
Send 4 byte real 2D data.