Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

mod_oasis_getput_interface.F90 @ 4775

Last change on this file since 4775 was 4775, checked in by aclsce, 4 years ago

Imported oasis3-mct from Cerfacs svn server (not suppotred anymore).

The version has been extracted from https://oasis3mct.cerfacs.fr/svn/branches/OASIS3-MCT_2.0_branch/oasis3-mct@1818

File size: 26.8 KB

Line
1	MODULE mod_oasis_getput_interface
2	!---------------------------------------------------------------------
3
4	use mod_oasis_kinds
5	use mod_oasis_data
6	use mod_oasis_parameters
7	use mod_oasis_advance
8	use mod_oasis_var
9	use mod_oasis_sys
10	use mct_mod
11
12	implicit none
13	private
14
15	public oasis_put
16	public oasis_get
17
18	#include "oasis_os.h"
19
20	integer(kind=ip_i4_p) istatus(MPI_STATUS_SIZE)
21
22	interface oasis_put
23	#ifndef __NO_4BYTE_REALS
24	module procedure oasis_put_r14
25	module procedure oasis_put_r24
26	#endif
27	module procedure oasis_put_r18
28	module procedure oasis_put_r28
29	end interface
30
31	interface oasis_get
32	#ifndef __NO_4BYTE_REALS
33	module procedure oasis_get_r14
34	module procedure oasis_get_r24
35	#endif
36	module procedure oasis_get_r18
37	module procedure oasis_get_r28
38	end interface
39
40	!---------------------------------------------------------------------
41	contains
42	!---------------------------------------------------------------------
43	SUBROUTINE oasis_put_r14(id_port_id,kstep,fld1,kinfo, &
44	fld2, fld3, fld4, fld5)
45
46	IMPLICIT none
47	!-------------------------------------
48	integer(kind=ip_i4_p) , intent(in) :: id_port_id,kstep
49	real(kind=ip_single_p) :: fld1(:)
50	integer(kind=ip_i4_p) , intent(out), optional :: kinfo
51	real(kind=ip_single_p), optional :: fld2(:)
52	real(kind=ip_single_p), optional :: fld3(:)
53	real(kind=ip_single_p), optional :: fld4(:)
54	real(kind=ip_single_p), optional :: fld5(:)
55	!-------------------------------------
56	integer(kind=ip_i4_p) :: nfld,ncpl
57	integer(kind=ip_i4_p) :: ns,nsx
58	integer(kind=ip_i4_p) :: n
59	logical :: a2on, a3on, a4on, a5on
60	character(len=*),parameter :: subname = 'oasis_put_r14'
61	!-------------------------------------
62
63	call oasis_debug_enter(subname)
64
65	kinfo = OASIS_OK
66
67	if (id_port_id == OASIS_Var_Uncpl) then
68	if (OASIS_debug >= 1) write(nulprt,*) subname, &
69	' Routine oasis_put is called for a variable not in namcouple: it will not be sent'
70	call oasis_abort_noarg()
71	return
72	endif
73
74	nfld = id_port_id
75	ncpl = prism_var(nfld)%ncpl
76
77	if (ncpl <= 0) then
78	if (OASIS_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
79	trim(prism_var(nfld)%name)
80	call oasis_debug_exit(subname)
81	return
82	endif
83
84	ns = size(fld1,dim=1)
85
86	a2on = .false.
87	a3on = .false.
88	a4on = .false.
89	a5on = .false.
90
91	if (present(fld2)) then
92	a2on = .true.
93	nsx = size(fld2,dim=1)
94	if (nsx /= ns) then
95	write(nulprt,*) subname,' ERROR fld2 size does not match fld1 ', &
96	trim(prism_var(nfld)%name)
97	CALL oasis_flush(nulprt)
98	CALL oasis_abort_noarg()
99	endif
100	endif
101
102	if (present(fld3)) then
103	a3on = .true.
104	nsx = size(fld3,dim=1)
105	if (nsx /= ns) then
106	write(nulprt,*) subname,' ERROR fld3 size does not match fld1 ', &
107	trim(prism_var(nfld)%name)
108	CALL oasis_flush(nulprt)
109	CALL oasis_abort_noarg()
110	endif
111	endif
112
113	if (present(fld4)) then
114	a4on = .true.
115	nsx = size(fld4,dim=1)
116	if (nsx /= ns) then
117	write(nulprt,*) subname,' ERROR array4 size does not match fld1 ', &
118	trim(prism_var(nfld)%name)
119	CALL oasis_flush(nulprt)
120	CALL oasis_abort_noarg()
121	endif
122	endif
123
124	if (present(fld5)) then
125	a5on = .true.
126	nsx = size(fld5,dim=1)
127	if (nsx /= ns) then
128	write(nulprt,*) subname,' ERROR fld5 size does not match fld1 ', &
129	trim(prism_var(nfld)%name)
130	CALL oasis_flush(nulprt)
131	CALL oasis_abort_noarg()
132	endif
133	endif
134
135
136	IF ((.NOT. a2on) .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
137	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
138	array1din= DBLE(fld1),readrest=.FALSE.)
139	ELSE IF (a2on .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
140	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
141	array1din= DBLE(fld1),readrest=.FALSE.,&
142	a2on=a2on,array2=DBLE(fld2))
143	ELSE IF (a2on .AND. a3on .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
144	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
145	array1din= DBLE(fld1),readrest=.FALSE.,&
146	a2on=a2on,array2=DBLE(fld2),&
147	a3on=a3on,array3=DBLE(fld3))
148	ELSE IF (a2on .AND. a3on .AND. a4on .AND. (.NOT. a5on)) THEN
149	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
150	array1din= DBLE(fld1),readrest=.FALSE.,&
151	a2on=a2on,array2=DBLE(fld2),&
152	a3on=a3on,array3=DBLE(fld3),&
153	a4on=a4on,array4=DBLE(fld4))
154	ELSE IF (a2on .AND. a3on .AND. a4on .AND. a5on) THEN
155	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
156	array1din= DBLE(fld1),readrest=.FALSE.,&
157	a2on=a2on,array2=DBLE(fld2),&
158	a3on=a3on,array3=DBLE(fld3),&
159	a4on=a4on,array4=DBLE(fld4),&
160	a5on=a5on,array5=DBLE(fld5))
161	ELSE
162	WRITE(nulprt,*) 'Wrong field array argument list in oasis_put'
163	CALL oasis_flush(nulprt)
164	ENDIF
165
166	call oasis_debug_exit(subname)
167
168	END SUBROUTINE oasis_put_r14
169
170	!-------------------------------------------------------------------
171	!---------------------------------------------------------------------
172	SUBROUTINE oasis_put_r18(id_port_id,kstep,fld1,kinfo, &
173	fld2, fld3, fld4, fld5)
174
175	IMPLICIT none
176	!-------------------------------------
177	integer(kind=ip_i4_p) , intent(in) :: id_port_id,kstep
178	real(kind=ip_double_p) :: fld1(:)
179	integer(kind=ip_i4_p) , intent(out), optional :: kinfo
180	real(kind=ip_double_p), optional :: fld2(:)
181	real(kind=ip_double_p), optional :: fld3(:)
182	real(kind=ip_double_p), optional :: fld4(:)
183	real(kind=ip_double_p), optional :: fld5(:)
184	!-------------------------------------
185	integer(kind=ip_i4_p) :: nfld,ncpl
186	integer(kind=ip_i4_p) :: ns,nsx
187	integer(kind=ip_i4_p) :: n
188	logical :: a2on, a3on, a4on, a5on
189	character(len=*),parameter :: subname = 'oasis_put_r18'
190	!-------------------------------------
191
192	call oasis_debug_enter(subname)
193
194	kinfo = OASIS_OK
195
196	if (id_port_id == OASIS_Var_Uncpl) then
197	if (OASIS_debug >= 1) write(nulprt,*) subname, &
198	' Routine oasis_put is called for a variable not in namcouple: it will not be sent'
199	call oasis_abort_noarg()
200	return
201	endif
202
203	nfld = id_port_id
204	ncpl = prism_var(nfld)%ncpl
205
206	if (ncpl <= 0) then
207	if (OASIS_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
208	trim(prism_var(nfld)%name)
209	call oasis_debug_exit(subname)
210	return
211	endif
212
213	ns = size(fld1,dim=1)
214
215	a2on = .false.
216	a3on = .false.
217	a4on = .false.
218	a5on = .false.
219
220	if (present(fld2)) then
221	a2on = .true.
222	nsx = size(fld2,dim=1)
223	if (nsx /= ns) then
224	write(nulprt,*) subname,' ERROR fld2 size does not match fld ', &
225	trim(prism_var(nfld)%name)
226	CALL oasis_flush(nulprt)
227	CALL oasis_abort_noarg()
228	endif
229	endif
230
231	if (present(fld3)) then
232	a3on = .true.
233	nsx = size(fld3,dim=1)
234	if (nsx /= ns) then
235	write(nulprt,*) subname,' ERROR fld3 size does not match fld ', &
236	trim(prism_var(nfld)%name)
237	CALL oasis_flush(nulprt)
238	CALL oasis_abort_noarg()
239	endif
240	endif
241
242	if (present(fld4)) then
243	a4on = .true.
244	nsx = size(fld4,dim=1)
245	if (nsx /= ns) then
246	write(nulprt,*) subname,' ERROR fld4 size does not match fld ', &
247	trim(prism_var(nfld)%name)
248	CALL oasis_flush(nulprt)
249	CALL oasis_abort_noarg()
250	endif
251	endif
252
253	if (present(fld5)) then
254	a5on = .true.
255	nsx = size(fld5,dim=1)
256	if (nsx /= ns) then
257	write(nulprt,*) subname,' ERROR fld5 size does not match fld ', &
258	trim(prism_var(nfld)%name)
259	CALL oasis_flush(nulprt)
260	CALL oasis_abort_noarg()
261	endif
262	endif
263
264	IF ((.NOT. a2on) .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
265	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
266	array1din=fld1,readrest=.FALSE.)
267	ELSE IF (a2on .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
268	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
269	array1din=fld1,readrest=.FALSE.,&
270	a2on=a2on,array2=fld2)
271	ELSE IF (a2on .AND. a3on .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
272	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
273	array1din= fld1,readrest=.FALSE.,&
274	a2on=a2on,array2=fld2,&
275	a3on=a3on,array3=fld3)
276	ELSE IF (a2on .AND. a3on .AND. a4on .AND. (.NOT. a5on)) THEN
277	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
278	array1din=fld1,readrest=.FALSE.,&
279	a2on=a2on,array2=fld2,&
280	a3on=a3on,array3=fld3,&
281	a4on=a4on,array4=fld4)
282	ELSE IF (a2on .AND. a3on .AND. a4on .AND. a5on) THEN
283	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
284	array1din=fld1,readrest=.FALSE.,&
285	a2on=a2on,array2=fld2,&
286	a3on=a3on,array3=fld3,&
287	a4on=a4on,array4=fld4,&
288	a5on=a5on,array5=fld5)
289	ELSE
290	WRITE(nulprt,*) 'Wrong field array argument list in oasis_put'
291	CALL oasis_flush(nulprt)
292	ENDIF
293
294	call oasis_debug_exit(subname)
295
296	END SUBROUTINE oasis_put_r18
297
298	!-------------------------------------------------------------------
299	!---------------------------------------------------------------------
300	SUBROUTINE oasis_put_r24(id_port_id,kstep,fld1,kinfo, &
301	fld2, fld3, fld4, fld5)
302
303	IMPLICIT none
304	!-------------------------------------
305	integer(kind=ip_i4_p) , intent(in) :: id_port_id,kstep
306	real(kind=ip_single_p) :: fld1(:,:)
307	integer(kind=ip_i4_p) , intent(out), optional :: kinfo
308	real(kind=ip_single_p), optional :: fld2(:,:)
309	real(kind=ip_single_p), optional :: fld3(:,:)
310	real(kind=ip_single_p), optional :: fld4(:,:)
311	real(kind=ip_single_p), optional :: fld5(:,:)
312	!-------------------------------------
313	integer(kind=ip_i4_p) :: nfld,ncpl
314	integer(kind=ip_i4_p) :: ns,nis,njs,nisx,njsx
315	integer(kind=ip_i4_p) :: n,ni,nj
316	logical :: a2on, a3on, a4on, a5on
317	character(len=*),parameter :: subname = 'oasis_put_r24'
318	!-------------------------------------
319
320	call oasis_debug_enter(subname)
321
322	kinfo = OASIS_OK
323
324	if (id_port_id == OASIS_Var_Uncpl) then
325	if (OASIS_debug >= 1) write(nulprt,*) subname, &
326	' Routine oasis_put is called for a variable not in namcouple: it will not be sent'
327	call oasis_abort_noarg()
328	return
329	endif
330
331	nfld = id_port_id
332	ncpl = prism_var(nfld)%ncpl
333
334	if (ncpl <= 0) then
335	if (OASIS_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
336	trim(prism_var(nfld)%name)
337	call oasis_debug_exit(subname)
338	return
339	endif
340
341	nis = size(fld1,dim=1)
342	njs = size(fld1,dim=2)
343	ns = nis*njs
344
345	a2on = .false.
346	a3on = .false.
347	a4on = .false.
348	a5on = .false.
349
350	if (present(fld2)) then
351	a2on = .true.
352	nisx = size(fld2,dim=1)
353	njsx = size(fld2,dim=2)
354	if (nisx /= nis .or. njsx /= njs) then
355	write(nulprt,*) subname,' ERROR fld2 size does not match fld ', &
356	trim(prism_var(nfld)%name)
357	CALL oasis_flush(nulprt)
358	CALL oasis_abort_noarg()
359	endif
360	endif
361
362	if (present(fld3)) then
363	a3on = .true.
364	nisx = size(fld3,dim=1)
365	njsx = size(fld3,dim=2)
366	if (nisx /= nis .or. njsx /= njs) then
367	write(nulprt,*) subname,' ERROR fld3 size does not match fld ', &
368	trim(prism_var(nfld)%name)
369	CALL oasis_flush(nulprt)
370	CALL oasis_abort_noarg()
371	endif
372	endif
373
374	if (present(fld4)) then
375	a4on = .true.
376	nisx = size(fld4,dim=1)
377	njsx = size(fld4,dim=2)
378	if (nisx /= nis .or. njsx /= njs) then
379	write(nulprt,*) subname,' ERROR fld4 size does not match fld ', &
380	trim(prism_var(nfld)%name)
381	CALL oasis_flush(nulprt)
382	CALL oasis_abort_noarg()
383	endif
384	endif
385
386	if (present(fld5)) then
387	a5on = .true.
388	nisx = size(fld5,dim=1)
389	njsx = size(fld5,dim=2)
390	if (nisx /= nis .or. njsx /= njs) then
391	write(nulprt,*) subname,' ERROR fld5 size does not match fld ', &
392	trim(prism_var(nfld)%name)
393	CALL oasis_flush(nulprt)
394	CALL oasis_abort_noarg()
395	endif
396	endif
397
398
399	IF ((.NOT. a2on) .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
400	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
401	array1din= DBLE(PACK(fld1, mask= .true.)),readrest=.FALSE.)
402	ELSE IF (a2on .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
403	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
404	array1din= DBLE(PACK(fld1, mask= .TRUE.)),readrest=.FALSE.,&
405	a2on=a2on,array2=DBLE(PACK(fld2, mask= .true.)))
406	ELSE IF (a2on .AND. a3on .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
407	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
408	array1din= DBLE(PACK(fld1, mask= .TRUE.)),readrest=.FALSE.,&
409	a2on=a2on,array2=DBLE(PACK(fld2, mask= .TRUE.)),&
410	a3on=a3on,array3=DBLE(PACK(fld3, mask= .TRUE.)))
411	ELSE IF (a2on .AND. a3on .AND. a4on .AND. (.NOT. a5on)) THEN
412	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
413	array1din= DBLE(PACK(fld1, mask= .TRUE.)),readrest=.FALSE.,&
414	a2on=a2on,array2=DBLE(PACK(fld2, mask= .TRUE.)),&
415	a3on=a3on,array3=DBLE(PACK(fld3, mask= .TRUE.)),&
416	a4on=a4on,array4=DBLE(PACK(fld4, mask= .TRUE.)))
417	ELSE IF (a2on .AND. a3on .AND. a4on .AND. a5on) THEN
418	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
419	array1din= DBLE(PACK(fld1, mask= .TRUE.)),readrest=.FALSE.,&
420	a2on=a2on,array2=DBLE(PACK(fld2, mask= .TRUE.)),&
421	a3on=a3on,array3=DBLE(PACK(fld3, mask= .TRUE.)),&
422	a4on=a4on,array4=DBLE(PACK(fld4, mask= .TRUE.)),&
423	a5on=a5on,array5=DBLE(PACK(fld5, mask= .TRUE.)))
424	ELSE
425	WRITE(nulprt,*) 'Wrong field array argument list in oasis_put'
426	CALL oasis_flush(nulprt)
427	ENDIF
428
429	call oasis_debug_exit(subname)
430
431	END SUBROUTINE oasis_put_r24
432
433	!-------------------------------------------------------------------
434	!---------------------------------------------------------------------
435	SUBROUTINE oasis_put_r28(id_port_id,kstep,fld1,kinfo, &
436	fld2, fld3, fld4, fld5)
437
438	IMPLICIT none
439	!-------------------------------------
440	integer(kind=ip_i4_p) , intent(in) :: id_port_id,kstep
441	real(kind=ip_double_p) :: fld1(:,:)
442	integer(kind=ip_i4_p) , intent(out), optional :: kinfo
443	real(kind=ip_double_p), optional :: fld2(:,:)
444	real(kind=ip_double_p), optional :: fld3(:,:)
445	real(kind=ip_double_p), optional :: fld4(:,:)
446	real(kind=ip_double_p), optional :: fld5(:,:)
447	!-------------------------------------
448	integer(kind=ip_i4_p) :: nfld,ncpl
449	integer(kind=ip_i4_p) :: ns,nis,njs,nisx,njsx
450	integer(kind=ip_i4_p) :: n,ni,nj
451	logical :: a2on, a3on, a4on, a5on
452	character(len=*),parameter :: subname = 'oasis_put_r28'
453	!-------------------------------------
454
455	call oasis_debug_enter(subname)
456
457	kinfo = OASIS_OK
458
459	if (id_port_id == OASIS_Var_Uncpl) then
460	if (OASIS_debug >= 1) write(nulprt,*) subname, &
461	' Routine oasis_put is called for a variable not in namcouple: it will not be sent'
462	call oasis_abort_noarg()
463	return
464	endif
465
466	nfld = id_port_id
467	ncpl = prism_var(nfld)%ncpl
468
469	if (ncpl <= 0) then
470	if (OASIS_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
471	trim(prism_var(nfld)%name)
472	call oasis_debug_exit(subname)
473	return
474	endif
475
476	nis = size(fld1,dim=1)
477	njs = size(fld1,dim=2)
478	ns = nis*njs
479
480	a2on = .false.
481	a3on = .false.
482	a4on = .false.
483	a5on = .false.
484
485	if (present(fld2)) then
486	a2on = .true.
487	nisx = size(fld2,dim=1)
488	njsx = size(fld2,dim=2)
489	if (nisx /= nis .or. njsx /= njs) then
490	write(nulprt,*) subname,' ERROR fld2 size does not match fld ', &
491	trim(prism_var(nfld)%name)
492	CALL oasis_flush(nulprt)
493	CALL oasis_abort_noarg()
494	endif
495	endif
496
497	if (present(fld3)) then
498	a3on = .true.
499	nisx = size(fld3,dim=1)
500	njsx = size(fld3,dim=2)
501	if (nisx /= nis .or. njsx /= njs) then
502	write(nulprt,*) subname,' ERROR fld3 size does not match fld ', &
503	trim(prism_var(nfld)%name)
504	CALL oasis_flush(nulprt)
505	CALL oasis_abort_noarg()
506	endif
507	endif
508
509	if (present(fld4)) then
510	a4on = .true.
511	nisx = size(fld4,dim=1)
512	njsx = size(fld4,dim=2)
513	if (nisx /= nis .or. njsx /= njs) then
514	write(nulprt,*) subname,' ERROR fld4 size does not match fld ', &
515	trim(prism_var(nfld)%name)
516	CALL oasis_flush(nulprt)
517	CALL oasis_abort_noarg()
518	endif
519	endif
520
521	if (present(fld5)) then
522	a5on = .true.
523	nisx = size(fld5,dim=1)
524	njsx = size(fld5,dim=2)
525	if (nisx /= nis .or. njsx /= njs) then
526	write(nulprt,*) subname,' ERROR fld5 size does not match fld ', &
527	trim(prism_var(nfld)%name)
528	CALL oasis_flush(nulprt)
529	CALL oasis_abort_noarg()
530	endif
531	endif
532
533
534	IF ((.NOT. a2on) .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
535	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo, &
536	array1din= (PACK(fld1, mask= .true.)),readrest=.FALSE.)
537	ELSE IF (a2on .AND. (.NOT. a3on) .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
538	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
539	array1din= (PACK(fld1, mask= .TRUE.)),readrest=.FALSE.,&
540	a2on=a2on,array2=(PACK(fld2, mask= .true.)))
541	ELSE IF (a2on .AND. a3on .AND. (.NOT. a4on) .AND. (.NOT. a5on)) THEN
542	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
543	array1din= (PACK(fld1, mask= .TRUE.)),readrest=.FALSE.,&
544	a2on=a2on,array2=(PACK(fld2, mask= .TRUE.)),&
545	a3on=a3on,array3=(PACK(fld3, mask= .TRUE.)))
546	ELSE IF (a2on .AND. a3on .AND. a4on .AND. (.NOT. a5on)) THEN
547	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
548	array1din= (PACK(fld1, mask= .TRUE.)),readrest=.FALSE.,&
549	a2on=a2on,array2=(PACK(fld2, mask= .TRUE.)),&
550	a3on=a3on,array3=(PACK(fld3, mask= .TRUE.)),&
551	a4on=a4on,array4=(PACK(fld4, mask= .TRUE.)))
552	ELSE IF (a2on .AND. a3on .AND. a4on .AND. a5on) THEN
553	CALL oasis_advance_run(OASIS_Out,nfld,kstep,kinfo,&
554	array1din= (PACK(fld1, mask= .TRUE.)),readrest=.FALSE.,&
555	a2on=a2on,array2=(PACK(fld2, mask= .TRUE.)),&
556	a3on=a3on,array3=(PACK(fld3, mask= .TRUE.)),&
557	a4on=a4on,array4=(PACK(fld4, mask= .TRUE.)),&
558	a5on=a5on,array5=(PACK(fld5, mask= .TRUE.)))
559	ELSE
560	WRITE(nulprt,*) 'Wrong field array argument list in oasis_put'
561	CALL oasis_flush(nulprt)
562	ENDIF
563
564	call oasis_debug_exit(subname)
565
566	END SUBROUTINE oasis_put_r28
567
568	!-------------------------------------------------------------------
569	!---------------------------------------------------------------------
570	SUBROUTINE oasis_get_r14(id_port_id,kstep,rd_field,kinfo)
571
572	IMPLICIT none
573	!-------------------------------------
574	integer(kind=ip_i4_p) , intent(in) :: id_port_id,kstep
575	real(kind=ip_single_p), intent(inout) :: rd_field(:)
576	integer(kind=ip_i4_p) , intent(out), optional :: kinfo
577	!-------------------------------------
578	integer(kind=ip_i4_p) :: nfld,ncpl
579	integer(kind=ip_i4_p) :: ns,nis,njs
580	integer(kind=ip_i4_p) :: n,ni,nj
581	real(kind=ip_r8_p), allocatable :: array(:)
582	character(len=*),parameter :: subname = 'oasis_get_r14'
583	!-------------------------------------
584
585	call oasis_debug_enter(subname)
586
587	kinfo = OASIS_OK
588
589	if (id_port_id == OASIS_Var_Uncpl) then
590	if (OASIS_debug >= 1) write(nulprt,*) subname, &
591	' Routine oasis_get is called for variable not in namcouple; it will not be received'
592	if (OASIS_debug >= 1) write(nulprt,*) subname,' BE CAREFUL NOT TO USE IT !!!!!'
593	call oasis_abort_noarg()
594	return
595	endif
596
597	nfld = id_port_id
598	ncpl = prism_var(nfld)%ncpl
599
600	if (ncpl <= 0) then
601	if (OASIS_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
602	trim(prism_var(nfld)%name)
603	call oasis_debug_exit(subname)
604	return
605	endif
606
607	ns = size(rd_field,dim=1)
608
609	allocate(array(ns))
610
611	CALL oasis_advance_run(OASIS_In,nfld,kstep,kinfo,array1dout=array,readrest=.FALSE.)
612
613	IF (kinfo /= OASIS_Ok) THEN
614	rd_field(:) = REAL(array(:))
615	ENDIF
616
617	deallocate(array)
618	call oasis_debug_exit(subname)
619
620	END SUBROUTINE oasis_get_r14
621
622	!---------------------------------------------------------------------
623	SUBROUTINE oasis_get_r18(id_port_id,kstep,rd_field,kinfo)
624
625	IMPLICIT none
626	!-------------------------------------
627	integer(kind=ip_i4_p) , intent(in) :: id_port_id,kstep
628	real(kind=ip_double_p), intent(inout) :: rd_field(:)
629	integer(kind=ip_i4_p) , intent(out), optional :: kinfo
630	!-------------------------------------
631	integer(kind=ip_i4_p) :: nfld,ncpl
632	integer(kind=ip_i4_p) :: ns,nis,njs
633	integer(kind=ip_i4_p) :: n,ni,nj
634	character(len=*),parameter :: subname = 'oasis_get_r18'
635	!-------------------------------------
636
637	call oasis_debug_enter(subname)
638
639	kinfo = OASIS_OK
640
641	if (id_port_id == OASIS_Var_Uncpl) then
642	if (OASIS_debug >= 1) write(nulprt,*) subname, &
643	' Routine oasis_get is called for variable not in namcouple; it will not be received'
644	if (OASIS_debug >= 1) write(nulprt,*) subname,' BE CAREFUL NOT TO USE IT !!!!!'
645	call oasis_abort_noarg()
646	return
647	endif
648
649	nfld = id_port_id
650	ncpl = prism_var(nfld)%ncpl
651
652	if (ncpl <= 0) then
653	if (OASIS_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
654	trim(prism_var(nfld)%name)
655	call oasis_debug_exit(subname)
656	return
657	endif
658
659	CALL oasis_advance_run(OASIS_In,nfld,kstep,kinfo,array1dout=rd_field,readrest=.FALSE.)
660
661	call oasis_debug_exit(subname)
662
663	END SUBROUTINE oasis_get_r18
664
665	!---------------------------------------------------------------------
666	SUBROUTINE oasis_get_r24(id_port_id,kstep,rd_field,kinfo)
667
668	IMPLICIT none
669	!-------------------------------------
670	integer(kind=ip_i4_p) , intent(in) :: id_port_id,kstep
671	real(kind=ip_single_p), intent(inout) :: rd_field(:,:)
672	integer(kind=ip_i4_p) , intent(out), optional :: kinfo
673	!-------------------------------------
674	integer(kind=ip_i4_p) :: nfld,ncpl
675	integer(kind=ip_i4_p) :: ns,nis,njs
676	integer(kind=ip_i4_p) :: n,ni,nj
677	REAL(kind=ip_r8_p), ALLOCATABLE :: array(:,:)
678	character(len=*),parameter :: subname = 'oasis_get_r24'
679	!-------------------------------------
680
681	call oasis_debug_enter(subname)
682
683	kinfo = OASIS_OK
684
685	if (id_port_id == OASIS_Var_Uncpl) then
686	if (OASIS_debug >= 1) write(nulprt,*) subname, &
687	' Routine oasis_get is called for variable not in namcouple; it will not be received'
688	if (OASIS_debug >= 1) write(nulprt,*) subname,' BE CAREFUL NOT TO USE IT !!!!!'
689	call oasis_abort_noarg()
690	return
691	endif
692
693	nfld = id_port_id
694	ncpl = prism_var(nfld)%ncpl
695
696	if (ncpl <= 0) then
697	if (OASIS_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
698	trim(prism_var(nfld)%name)
699	call oasis_debug_exit(subname)
700	return
701	endif
702
703	nis = size(rd_field,dim=1)
704	njs = size(rd_field,dim=2)
705	ns = nis*njs
706
707	ALLOCATE(array(nis,njs))
708
709	CALL oasis_advance_run(OASIS_In,nfld,kstep,kinfo,array2dout=array,readrest=.FALSE.)
710
711	IF (kinfo /= OASIS_Ok) THEN
712	rd_field(:,:) = REAL(array(:,:))
713	ENDIF
714
715	deallocate(array)
716	call oasis_debug_exit(subname)
717
718	END SUBROUTINE oasis_get_r24
719
720	!---------------------------------------------------------------------
721	SUBROUTINE oasis_get_r28(id_port_id,kstep,rd_field,kinfo)
722
723	IMPLICIT none
724	!-------------------------------------
725	integer(kind=ip_i4_p) , intent(in) :: id_port_id,kstep
726	real(kind=ip_double_p), intent(inout) :: rd_field(:,:)
727	integer(kind=ip_i4_p) , intent(out), optional :: kinfo
728	!-------------------------------------
729	integer(kind=ip_i4_p) :: nfld,ncpl
730	integer(kind=ip_i4_p) :: ns,nis,njs
731	integer(kind=ip_i4_p) :: n,ni,nj
732	character(len=*),parameter :: subname = 'oasis_get_r28'
733	!-------------------------------------
734
735	call oasis_debug_enter(subname)
736
737	kinfo = OASIS_OK
738
739	if (id_port_id == OASIS_Var_Uncpl) then
740	if (OASIS_debug >= 1) write(nulprt,*) subname, &
741	' Routine oasis_get is called for variable not in namcouple; it will not be received'
742	if (OASIS_debug >= 1) write(nulprt,*) subname,' BE CAREFUL NOT TO USE IT !!!!!'
743	call oasis_abort_noarg()
744	return
745	endif
746
747	nfld = id_port_id
748	ncpl = prism_var(nfld)%ncpl
749
750	if (ncpl <= 0) then
751	if (OASIS_debug >= 15) write(nulprt,*) subname,' variable not coupled ',&
752	trim(prism_var(nfld)%name)
753	call oasis_debug_exit(subname)
754	return
755	endif
756
757	CALL oasis_advance_run(OASIS_In,nfld,kstep,kinfo,array2dout=rd_field,readrest=.FALSE.)
758
759	call oasis_debug_exit(subname)
760
761	END SUBROUTINE oasis_get_r28
762
763	!-------------------------------------------------------------------
764
765	END MODULE mod_oasis_getput_interface
766

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: CPL/oasis3-mct/branches/OASIS3-MCT_2.0_branch/lib/psmile/src/mod_oasis_getput_interface.F90 @ 4775

Download in other formats: