Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

mod_prism_put_proto.F90 @ 1677

Last change on this file since 1677 was 1677, checked in by aclsce, 12 years ago
Imported oasis3 (tag ipslcm5a) from cvs server to svn server (igcmg project).
File size: 44.9 KB

Line
1	module mod_prism_put_proto
2	#include <psmile_os.h>
3
4	interface prism_put_proto
5
6	#ifndef __NO_4BYTE_REALS
7	module procedure prism_put_proto_r14
8	module procedure prism_put_proto_r24
9	#endif
10	module procedure prism_put_proto_r18, &
11	prism_put_proto_r28
12
13	end interface
14
15	contains
16	#ifndef __NO_4BYTE_REALS
17	SUBROUTINE prism_put_proto_r14(id_port_id,kstep,rd_field,kinfo)
18	!
19	!* * PRISM_put * PRISM 1.0
20	!
21	! purpose:
22	! --------
23	! give pfield to Oasis or models connected to port id_port_id at the
24	! time kstep
25	!
26	! interface:
27	! ----------
28	! id_port_id : port number of the field
29	! kstep : current time in seconds
30	! rd_field : buffer of reals
31	! kinfo : output status
32	!
33	! lib mp:
34	! -------
35	! mpi-1
36	!
37	! author:
38	! -------
39	! Arnaud Caubel - Fecit (08/02 - created from CLIM_Export)
40	!
41	! modified:
42	! ---------
43	! Reiner Vogelsang, SGI, 27 April 2003
44	! - Screening of 4 byte real interfaces in case a of dbl4 compilation.
45	! File has to be preprocessed with -D__SXdbl4.
46	! S. Legutke, MPI-HH M&D, 13 May 2003
47	! - return PRISM_Sent if a field was received
48	! ----------------------------------------------------------------
49	USE mod_kinds_model
50	USE mod_prism_proto
51	USE mod_comprism_proto
52	USE mathelp_psmile
53	IMPLICIT NONE
54	#include <mpif.h>
55	! ----------------------------------------------------------------
56	INTEGER (kind=ip_intwp_p) kstep, kinfo, id_port_id
57	REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rd_field
58	! ----------------------------------------------------------------
59	INTEGER (kind=ip_intwp_p) il_newtime
60	INTEGER (kind=ip_intwp_p) info, ib
61	INTEGER (kind=ip_intwp_p) isend, ip, iport, ilk, iseg, is, ilgb
62	INTEGER (kind=ip_intwp_p) imod, itid, itag, il_len, ioff, ityp, ibyt
63	INTEGER (kind=ip_intwp_p) iposbuf
64	INTEGER (kind=ip_intwp_p) :: il_nbopp, il_nbin, il_nbout
65	INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbopp_max = 10
66	INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbindex=1
67	INTEGER (kind=ip_intwp_p) :: il_nindex(ip_nbindex)
68	REAL(kind=ip_single_p) :: rl_tmp_scal(ip_nbopp_max)
69	REAL(kind=ip_single_p),PARAMETER :: ip_missing_val=1.e20
70	REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rl_field_aux
71	CHARACTER(len=80) :: cl_topps, cl_str
72	CHARACTER(len=7) :: cl_tmp_topp, cl_tmp_sopp(ip_nbopp_max)
73	! ----------------------------------------------------------------
74	isend = 0
75	iport = -1
76	! Test if the field is defined in the namcouple and if its coupling period
77	! is not greater than the time of the simulation.
78	IF (ig_def_freq(id_port_id) .eq. 0.or. &
79	ig_def_freq(id_port_id) .gt. ig_ntime) THEN
80	GOTO 1010
81	ENDIF
82	!
83	!
84	! if a field exported at a certain time should match an import
85	! at a time+lag, add the lag here; the lag is given by the user
86	! in the namcouple at the end of the field 2nd line.
87	IF (myport(1,id_port_id).eq.CLIM_Out) THEN
88	iport=id_port_id
89	il_newtime = kstep + ig_def_lag(iport)
90	ENDIF
91
92	IF (iport.lt.0) THEN
93	kinfo = CLIM_BadPort
94	WRITE(nulprt,FMT='(A,A)') &
95	'Put - WARNING - Invalid port out: ', &
96	cports(id_port_id)
97	GO TO 1010
98	ENDIF
99
100	rl_field_aux(:)=0
101	cl_tmp_sopp(:)=' '
102	il_nindex(:)=0
103	rl_tmp_scal(:)=0
104	!
105	!* 0. First check
106	! --------------
107	!
108	IF (nexit.ne.1) THEN
109	kinfo = CLIM_FastExit
110	WRITE(nulprt,FMT='(A)') 'Put - should not be called'
111	GO TO 1010
112	ENDIF
113	kinfo = PRISM_Ok
114	lg_dgfield = .false.
115	!
116	!* 1. check for this port in my list
117	! ---------------------------------
118	!
119	! If the user indicated in the namcouple that the field must be
120	! accumulated or averaged (keyword 'AVERAGE' or 'ACCUMUL' at the
121	! end of the field 2nd line), do the local transformations.
122	!
123	IF (ig_def_trans(iport) .EQ. ip_instant) THEN
124	cl_str = 'inst(ident(X))'
125	rg_field_trans(:,iport) = rd_field (:)
126	ELSEIF (ig_def_trans(iport) .eq. ip_average .or. &
127	ig_def_trans(iport) .EQ. ip_accumul .OR. &
128	ig_def_trans(iport) .EQ. ip_min .OR. &
129	ig_def_trans(iport) .EQ. ip_max) THEN
130	IF (ig_number(iport) .EQ. 0) rg_field_trans(:,iport) = 0
131	il_nbin = myport(4,iport)
132	il_nbout = il_nbin
133	cl_topps = 'ave, inst, t_sum, t_min, t_max'
134	IF (ig_def_trans(iport) .EQ. ip_average) THEN
135	cl_str = 'ave(ident(X))'
136	ELSEIF (ig_def_trans(iport) .EQ. ip_accumul) THEN
137	cl_str = 't_sum(ident(X))'
138	ELSEIF (ig_def_trans(iport) .EQ. ip_min) THEN
139	cl_str = 't_min(ident(X))'
140	ELSEIF (ig_def_trans(iport) .EQ. ip_max) THEN
141	cl_str = 't_max(ident(X))'
142	ENDIF
143	CALL buildop (cl_str,cl_topps,cl_tmp_topp,ip_nbopp_max, &
144	ip_missing_val,cl_tmp_sopp,rl_tmp_scal,il_nbopp)
145
146	CALL mathop (cl_tmp_sopp(1), il_nbin, rd_field, ip_missing_val, &
147	ip_nbindex, il_nindex, rl_tmp_scal(1), il_nbout, &
148	rl_field_aux)
149
150	IF ((cl_tmp_topp(:LEN_TRIM(cl_tmp_topp)) .NE. 'inst')) &
151	CALL moycum(cl_tmp_topp, il_nbin, rg_field_trans(:,iport), &
152	rl_field_aux, ig_number(iport))
153	ig_number(iport) = ig_number(iport) + 1
154	IF (MOD(il_newtime,ig_def_freq(iport)) .EQ. 0) THEN
155	ig_number(iport) = 0
156	DO ib = 1, myport(4,iport)
157	rd_field(ib) = rg_field_trans(ib,iport)
158	ENDDO
159	ENDIF
160	kinfo = PRISM_LocTrans
161	ENDIF
162	!
163	!* Test if field must be written to restart file i.e.
164	!* - current time is time at the end of simulation +
165	!* - lag of current field is greater 0
166	!
167	IF (il_newtime.EQ.ig_ntime.AND.ig_def_lag(iport).GT.0) THEN
168	!ac
169	IF (ig_def_state(iport) .ne. ip_output) THEN
170	!ac
171	!
172	!* Note: A model can have several restart files but same restart
173	!* file can't be used by different models
174	!
175	IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
176	CALL write_filer4(rd_field,cports(iport),iport)
177	ELSE
178	CALL write_file_parar4(rd_field,cports(iport),iport)
179	ENDIF
180	kinfo = PRISM_ToRest
181	!ac
182	ENDIF
183	!ac
184	! Test if the current time is a coupling (or I/O) time
185	IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN
186
187	#if !defined key_noIO
188	!* If the user indicated in the namcouple that the field is
189	!* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
190	!* at the end of the field 1st line), do the writing to file here, e.g.:
191	!ac
192	IF (ig_def_state(iport) .EQ. ip_output ) THEN
193	CALL psmile_write_4(iport,rd_field,il_newtime)
194	kinfo = PRISM_Output
195	ELSEIF (ig_def_state(iport) .eq. ip_expout .or. &
196	ig_def_state(iport) .EQ. ip_ignout) THEN
197	CALL psmile_write_4(iport,rd_field,il_newtime)
198	kinfo = PRISM_ToRestOut
199	ENDIF
200	!ac
201	#endif
202	ENDIF
203	ELSE
204	! Test if the current time is a coupling (or I/O) time
205	IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN
206	!
207	#if !defined key_noIO
208	!* If the user indicated in the namcouple that the field is
209	!* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
210	!* at the end of the field 1st line), do the writing to file here, e.g.:
211	IF (ig_def_state(iport) .EQ. ip_output .OR. &
212	ig_def_state(iport) .EQ. ip_expout .OR. &
213	ig_def_state(iport) .EQ. ip_ignout) THEN
214	CALL psmile_write_4(iport,rd_field,il_newtime)
215	kinfo = PRISM_Output
216	ENDIF
217	#endif
218	!*
219	!* If the user indicated in the namcouple that the field is
220	!* a coupling field (keyword EXPORTED','EXPOUT','IGNORED' or 'IGNOUT'
221	!* at the end of the field 1st line),do the export here.
222	!*
223	IF (ig_def_state(iport) .EQ. ip_expout .OR. &
224	ig_def_state(iport) .eq. ip_exported .or. &
225	ig_def_state(iport) .eq. ip_ignored .or. &
226	ig_def_state(iport) .eq. ip_ignout .or. &
227	ig_def_state(iport) .eq. ip_auxilary) THEN
228
229	!
230	!* check for connected ports (in)
231	! ------------------------------
232	!
233	WRITE(nulprt,FMT='(A,A)') 'Put - ', cports(iport)
234	!
235	ityp = myport(2,iport)
236	ibyt = myport(3,iport)
237	!
238	DO ip=1,myport(5,iport)
239	!
240	ilk = myport(5+ip,iport)
241	imod = mylink(1,ilk)
242	itid = mylink(2,ilk)
243	itag = mylink(3,ilk) - il_newtime / ig_frqmin
244	iseg = mylink(4,ilk)
245	!
246	ilgb = 0
247	iposbuf = 0
248	DO is=1,iseg
249	ioff = mylink(4+2is-1,ilk) 2 + 1
250	il_len = mylink(4+2*is,ilk)
251	!
252	IF ( ityp .EQ. PRISM_Real ) THEN
253	CALL MPI_Pack ( rd_field(ioff), il_len, &
254	MPI_REAL,pkwork_field, ig_maxtype_field, iposbuf, &
255	mpi_comm, info )
256	ELSE
257	WRITE(nulprt,*)'Put - pb type incorrect ', ityp
258	kinfo = CLIM_BadType
259	GO TO 1010
260	ENDIF
261	ilgb = ilgb + il_len
262	ENDDO
263	IF (info.ne.0 .or. ilgb*ibyt .gt. ig_maxtype_field) THEN
264	kinfo = CLIM_Pack
265	WRITE(nulprt,FMT='(A,I3,I8,A)') &
266	'Put - pb pack<mpi ',info,ilgb*ibyt,'>'
267	ELSE
268	!*
269	IF (lg_clim_bsend) THEN
270	!* Buffered send
271	!* -> if fields are not sent and received in the same order, and
272	!* and on architectures on which MPI_Send is not implemented with a
273	!* mailbox (e.g. NEC SX5)
274	!*
275	CALL MPI_BSend ( pkwork_field, iposbuf, &
276	MPI_PACKED, itid, itag, mpi_comm, info )
277	ELSE
278	!*
279	!* Standard blocking send: To be used
280	!* -> if fields are necessarily sent and received in the same order,
281	!* -> or on architectures on which MPI_Send is implemented with a
282	!* mailbox (e.g. VPPs); in this case, make sure that your mailbox
283	!* size is large enough.
284	!
285	CALL MPI_Send ( pkwork_field, iposbuf, &
286	MPI_PACKED, itid, itag, mpi_comm, info )
287	!
288	ENDIF
289	!
290	IF (info.eq.CLIM_ok) THEN
291	isend = isend + 1
292	nbsend = nbsend + ilgb * ibyt
293	WRITE(nulprt,FMT='(A,I2,A,I6,A,I7,A,I2,A,I10,A,I6,A)') &
294	'Put - <dest:',imod, &
295	'> <step:',il_newtime, &
296	'> <len:',ilgb, &
297	'> <type:',ibyt, &
298	'> <tag:',itag, &
299	'> <comm:',mpi_comm,'>'
300	ELSE
301	kinfo = CLIM_Pvm
302	WRITE(nulprt,FMT='(A,I3,A)') &
303	'Put - pb send <mpi ',info,'>'
304	ENDIF
305	ENDIF
306	!
307	ENDDO
308	!
309	IF (kinfo .EQ. PRISM_Output) THEN
310	kinfo = PRISM_SentOut
311	ELSE
312	kinfo = PRISM_Sent
313	ENDIF
314
315	WRITE(nulprt,FMT='(A,I3,A)') &
316	'Put r14- ',isend,' fields exported'
317	ENDIF
318	ENDIF
319	ENDIF
320	!
321	! ----------------------------------------------------------------
322	!
323	1010 CONTINUE
324	CALL FLUSH(nulprt)
325	RETURN
326	END SUBROUTINE prism_put_proto_r14
327	#endif
328	SUBROUTINE prism_put_proto_r18(id_port_id,kstep,rd_field,kinfo)
329	!
330	!* * PRISM_put * PRISM 1.0
331	!
332	! purpose:
333	! --------
334	! give rd_field to Oasis or models connected to port id_port_id at the
335	! time kstep
336	!
337	! interface:
338	! ----------
339	! id_port_id : port number of the field
340	! kstep : current time in seconds
341	! rd_field : buffer of reals
342	! kinfo : output status
343	!
344	! lib mp:
345	! -------
346	! mpi-1
347	!
348	! author:
349	! -------
350	! Arnaud Caubel - Fecit (08/02 - created from CLIM_Export)
351	! ----------------------------------------------------------------
352	USE mod_kinds_model
353	USE mod_prism_proto
354	USE mod_comprism_proto
355	USE mathelp_psmile
356	IMPLICIT NONE
357	#include <mpif.h>
358	! ----------------------------------------------------------------
359	INTEGER (kind=ip_intwp_p) kstep, kinfo, id_port_id
360	REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rd_field
361	! ----------------------------------------------------------------
362	INTEGER (kind=ip_intwp_p) il_newtime
363	INTEGER (kind=ip_intwp_p) info
364	INTEGER (kind=ip_intwp_p) isend, ip, iport, ilk, iseg, is, ilgb, &
365	imod, itid, itag, il_len, ioff, ityp, ibyt
366	INTEGER (kind=ip_intwp_p) iposbuf
367	INTEGER (kind=ip_intwp_p) :: ib, il_nbopp, il_nbin, il_nbout
368	INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbopp_max = 10
369	INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbindex=1
370	INTEGER (kind=ip_intwp_p) :: il_nindex(ip_nbindex)
371	REAL(kind=ip_double_p) :: rl_tmp_scal(ip_nbopp_max)
372	REAL(kind=ip_double_p),PARAMETER :: ip_missing_val=1.e20
373	REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rl_field_aux
374	CHARACTER(len=80) :: cl_topps, cl_str
375	CHARACTER(len=7) :: cl_tmp_topp, cl_tmp_sopp(ip_nbopp_max)
376	! ----------------------------------------------------------------
377	isend = 0
378	iport = -1
379	!
380	! Test if the field is defined in the namcouple and if its coupling period
381	! is not greater than the time of the simulation.
382	IF (ig_def_freq(id_port_id) .eq. 0.or. &
383	ig_def_freq(id_port_id) .gt. ig_ntime) THEN
384	GOTO 1010
385	ENDIF
386	!
387	! if a field exported at a certain time should match an import
388	! at a time+lag, add the lag here; the lag is given by the user
389	! in the namcouple at the end of the field 2nd line.
390	IF (myport(1,id_port_id).eq.CLIM_Out) THEN
391	iport=id_port_id
392	il_newtime = kstep + ig_def_lag(iport)
393	ENDIF
394
395	IF (iport.LT.0) THEN
396	kinfo = CLIM_BadPort
397	WRITE(nulprt,FMT='(A,A)') &
398	'Put - WARNING - Invalid port out: ', &
399	cports(id_port_id)
400	GO TO 1010
401	ENDIF
402
403	rl_field_aux(:)=0
404	cl_tmp_sopp(:)=' '
405	il_nindex(:)=0
406	rl_tmp_scal(:)=0
407	!
408	!* 0. First check
409	! --------------
410	!
411	IF (nexit.ne.1) THEN
412	kinfo = CLIM_FastExit
413	WRITE(nulprt,FMT='(A)') 'Put - should not be called'
414	GO TO 1010
415	ENDIF
416	kinfo = PRISM_Ok
417	lg_dgfield = .true.
418	!
419	!* 1. check for this port in my list
420	! ---------------------------------
421	!
422	!
423	! If the user indicated in the namcouple that the field must be
424	! accumulated or averaged (keyword 'AVERAGE' or 'ACCUMUL' at the
425	! end of the field 2nd line), do the local transformations.
426	!
427	IF (ig_def_trans(iport) .EQ. ip_instant) THEN
428	cl_str = 'inst(ident(X))'
429	dg_field_trans(:,iport) = rd_field (:)
430	ELSEIF (ig_def_trans(iport) .eq. ip_average .or. &
431	ig_def_trans(iport) .EQ. ip_accumul .OR. &
432	ig_def_trans(iport) .EQ. ip_min .OR. &
433	ig_def_trans(iport) .EQ. ip_max) THEN
434	IF (ig_number(iport) .EQ. 0) dg_field_trans(:,iport) = 0
435	il_nbin = myport(4,iport)
436	il_nbout = il_nbin
437	cl_topps = 'ave, inst, t_sum, t_min, t_max'
438	IF (ig_def_trans(iport) .EQ. ip_average) THEN
439	cl_str = 'ave(ident(X))'
440	ELSEIF (ig_def_trans(iport) .EQ. ip_accumul) THEN
441	cl_str = 't_sum(ident(X))'
442	ELSEIF (ig_def_trans(iport) .EQ. ip_min) THEN
443	cl_str = 't_min(ident(X))'
444	ELSEIF (ig_def_trans(iport) .EQ. ip_max) THEN
445	cl_str = 't_max(ident(X))'
446	ENDIF
447	CALL buildop (cl_str,cl_topps,cl_tmp_topp,ip_nbopp_max, &
448	ip_missing_val,cl_tmp_sopp,rl_tmp_scal,il_nbopp)
449
450	CALL mathop (cl_tmp_sopp(1), il_nbin, rd_field, ip_missing_val, &
451	ip_nbindex, il_nindex, rl_tmp_scal(1), il_nbout, &
452	rl_field_aux)
453
454	IF ((cl_tmp_topp(:LEN_TRIM(cl_tmp_topp)) .NE. 'inst')) &
455	CALL moycum(cl_tmp_topp, il_nbin, dg_field_trans(:,iport), &
456	rl_field_aux, ig_number(iport))
457	ig_number(iport) = ig_number(iport) + 1
458	IF (MOD(il_newtime,ig_def_freq(iport)) .EQ. 0) THEN
459	ig_number(iport) = 0
460	DO ib = 1, myport(4,iport)
461	rd_field(ib) = dg_field_trans(ib,iport)
462	ENDDO
463	ENDIF
464	kinfo = PRISM_LocTrans
465	ENDIF
466	!
467	!* Test if field must be written to restart file i.e.
468	!* - current time is time at the end of simulation +
469	!* - lag of current field is greater 0
470	!
471	IF (il_newtime.eq.ig_ntime.and.ig_def_lag(iport).gt.0) THEN
472	!ac
473	IF (ig_def_state(iport) .ne. ip_output) THEN
474	!ac
475	!
476	!* Note: A model can have several restart files but same restart
477	!* file can't be used by different models
478	!
479	IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
480	CALL write_filer8(rd_field,cports(iport),iport)
481	ELSE
482	CALL write_file_parar8(rd_field,cports(iport),iport)
483	ENDIF
484	kinfo = PRISM_ToRest
485	!ac
486	ENDIF
487	!ac
488	! Test if the current time is a coupling (or I/O) time
489	IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN
490
491	#if !defined key_noIO
492	!* If the user indicated in the namcouple that the field is
493	!* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
494	!* at the end of the field 1st line), do the writing to file here, e.g.:
495	!ac
496	IF (ig_def_state(iport) .EQ. ip_output ) THEN
497	CALL psmile_write_8(iport,rd_field,il_newtime)
498	kinfo = PRISM_Output
499	ELSEIF (ig_def_state(iport) .eq. ip_expout .or. &
500	ig_def_state(iport) .EQ. ip_ignout) THEN
501	CALL psmile_write_8(iport,rd_field,il_newtime)
502	kinfo = PRISM_ToRestOut
503	ENDIF
504	!ac
505	#endif
506	ENDIF
507	ELSE
508
509	! Test if the current time is a coupling (or I/O) time
510	IF (mod(il_newtime,ig_def_freq(iport)).eq.0) THEN
511	!
512	#if !defined key_noIO
513	!* If the user indicated in the namcouple that the field is
514	!* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
515	!* at the end of the field 1st line), do the writing to file here, e.g.:
516	IF (ig_def_state(iport) .eq. ip_output .or. &
517	ig_def_state(iport) .eq. ip_expout .or. &
518	ig_def_state(iport) .eq. ip_ignout) THEN
519	call psmile_write_8(iport,rd_field,il_newtime)
520	kinfo = PRISM_Output
521	ENDIF
522	#endif
523	!*
524	!* If the user indicated in the namcouple that the field is
525	!* a coupling field (keyword EXPORTED','EXPOUT','IGNORED' or 'IGNOUT'
526	!* at the end of the field 1st line),do the export here.
527	!*
528	IF (ig_def_state(iport) .eq. ip_expout .or. &
529	ig_def_state(iport) .eq. ip_exported .or. &
530	ig_def_state(iport) .eq. ip_ignored .or. &
531	ig_def_state(iport) .eq. ip_ignout .or. &
532	ig_def_state(iport) .eq. ip_auxilary) THEN
533
534	!
535	!* check for connected ports (in)
536	! ------------------------------
537	!
538	WRITE(nulprt,FMT='(A,A)') 'Put - ', cports(iport)
539	!
540	ityp = myport(2,iport)
541	ibyt = myport(3,iport)
542	!
543	DO ip=1,myport(5,iport)
544	!
545	ilk = myport(5+ip,iport)
546	imod = mylink(1,ilk)
547	itid = mylink(2,ilk)
548	itag = mylink(3,ilk) - il_newtime / ig_frqmin
549	iseg = mylink(4,ilk)
550	!
551	ilgb = 0
552	iposbuf = 0
553	DO is=1,iseg
554	ioff = mylink(4+2*is-1,ilk) + 1
555	il_len = mylink(4+2*is,ilk)
556	!
557	! IF ( ityp .EQ. PRISM_Real .or. ityp .EQ. PRISM_Double) THEN
558	IF ( ityp .EQ. PRISM_Real ) THEN
559	CALL MPI_Pack ( rd_field(ioff), il_len, &
560	MPI_DOUBLE_PRECISION, pkwork_field, &
561	ig_maxtype_field, iposbuf, &
562	mpi_comm, info )
563	ELSE
564	WRITE(nulprt,*)'Put - pb type incorrect ', ityp
565	kinfo = CLIM_BadType
566	GO TO 1010
567	ENDIF
568	ilgb = ilgb + il_len
569	ENDDO
570	IF (info.ne.0 .or. ilgb*ibyt .gt. ig_maxtype_field) THEN
571	kinfo = CLIM_Pack
572	WRITE(nulprt,FMT='(A,I3,I8,A)') &
573	'Put - pb pack<mpi ',info,ilgb*ibyt,'>'
574	ELSE
575	IF (lg_clim_bsend) THEN
576	!*
577	!* Buffered send
578	!* -> if fields are not sent and received in the same order, and
579	!* and on architectures on which MPI_Send is not implemented with a
580	!* mailbox (e.g. NEC SX5)
581	!*
582	CALL MPI_BSend ( pkwork_field, iposbuf, &
583	MPI_PACKED, itid, itag, mpi_comm, info )
584	ELSE
585	!*
586	!* Standard blocking send: To be used
587	!* -> if fields are necessarily sent and received in the same order,
588	!* -> or on architectures on which MPI_Send is implemented with a
589	!* mailbox (e.g. VPPs); in this case, make sure that your mailbox
590	!* size is large enough.
591	!
592	CALL MPI_Send ( pkwork_field, iposbuf, &
593	MPI_PACKED, itid, itag, mpi_comm, info )
594	!
595	ENDIF
596	!
597	IF (info.eq.CLIM_ok) THEN
598	isend = isend + 1
599	nbsend = nbsend + ilgb * ibyt
600	WRITE(nulprt,FMT='(A,I2,A,I6,A,I7,A,I2,A,I10,A)') &
601	'Put - <dest:',imod, &
602	'> <step:',il_newtime, &
603	'> <len:',ilgb, &
604	'> <type:',ibyt, &
605	'> <tag:',itag,'>'
606	ELSE
607	kinfo = CLIM_Pvm
608	WRITE(nulprt,FMT='(A,I3,A)') &
609	'Put - pb send <mpi ',info,'>'
610	ENDIF
611	ENDIF
612	!
613	ENDDO
614	!
615	IF (kinfo .EQ. PRISM_Output) THEN
616	kinfo = PRISM_SentOut
617	ELSE
618	kinfo = PRISM_Sent
619	ENDIF
620
621	WRITE(nulprt,FMT='(A,I3,A)') &
622	'Put r18- ',isend,' fields exported'
623	ENDIF
624	ENDIF
625	ENDIF
626	!
627	! ----------------------------------------------------------------
628	!
629	1010 CONTINUE
630	CALL FLUSH(nulprt)
631	RETURN
632	END SUBROUTINE prism_put_proto_r18
633	#ifndef __NO_4BYTE_REALS
634	SUBROUTINE prism_put_proto_r24(id_port_id,kstep,rd_field_2d,kinfo)
635	!
636	!* * PRISM_put * PRISM 1.0
637	!
638	! purpose:
639	! --------
640	! give pfield to Oasis or models connected to port id_port_id at the
641	! time kstep
642	!
643	! interface:
644	! ----------
645	! id_port_id : port number of the field
646	! kstep : current time in seconds
647	! rd_field : buffer of reals
648	! kinfo : output status
649	!
650	! lib mp:
651	! -------
652	! mpi-1
653	!
654	! author:
655	! -------
656	! Arnaud Caubel - Fecit (08/02 - created from CLIM_Export)
657	! ----------------------------------------------------------------
658	USE mod_kinds_model
659	USE mod_prism_proto
660	USE mod_comprism_proto
661	USE mathelp_psmile
662	IMPLICIT NONE
663	#include <mpif.h>
664	! ----------------------------------------------------------------
665	INTEGER (kind=ip_intwp_p) kstep, kinfo, id_port_id
666	REAL(kind=ip_single_p), DIMENSION(:,:) :: rd_field_2d
667	! ----------------------------------------------------------------
668	REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rd_field
669
670	INTEGER (kind=ip_intwp_p) il_newtime
671	INTEGER (kind=ip_intwp_p) info, ib
672	INTEGER (kind=ip_intwp_p) isend, ip, iport, ilk, iseg, is, ilgb
673	INTEGER (kind=ip_intwp_p) imod, itid, itag, il_len, ioff, ityp, ibyt
674	INTEGER (kind=ip_intwp_p) iposbuf
675	INTEGER (kind=ip_intwp_p) :: il_nbopp, il_nbin, il_nbout
676	INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbopp_max = 10
677	INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbindex=1
678	INTEGER (kind=ip_intwp_p) :: il_nindex(ip_nbindex)
679	REAL(kind=ip_single_p) :: rl_tmp_scal(ip_nbopp_max)
680	REAL(kind=ip_single_p),PARAMETER :: ip_missing_val=1.e20
681	REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rl_field_aux
682	CHARACTER(len=80) :: cl_topps, cl_str
683	CHARACTER(len=7) :: cl_tmp_topp, cl_tmp_sopp(ip_nbopp_max)
684	! ----------------------------------------------------------------
685	isend = 0
686	iport = -1
687	!
688	!
689	! Test if the field is defined in the namcouple and if its coupling period
690	! is not greater than the time of the simulation.
691	IF (ig_def_freq(id_port_id) .eq. 0 .or. &
692	ig_def_freq(id_port_id) .gt. ig_ntime) THEN
693	GOTO 1010
694	ENDIF
695	! if a field exported at a certain time should match an import
696	! at a time+lag, add the lag here; the lag is given by the user
697	! in the namcouple at the end of the field 2nd line.
698	IF (myport(1,id_port_id).eq.CLIM_Out) THEN
699	iport=id_port_id
700	il_newtime = kstep + ig_def_lag(iport)
701	ENDIF
702
703	IF (iport.lt.0) THEN
704	kinfo = CLIM_BadPort
705	WRITE(nulprt,FMT='(A,A)') &
706	'Put - WARNING - Invalid port out: ', &
707	cports(id_port_id)
708	GO TO 1010
709	ENDIF
710
711	rd_field(1:myport(4,id_port_id)) = RESHAPE (rd_field_2d(:,:), &
712	(/myport(4,id_port_id)/))
713	rl_field_aux(:)=0
714	cl_tmp_sopp(:)=' '
715	il_nindex(:)=0
716	rl_tmp_scal(:)=0
717	!
718	!* 0. First check
719	! --------------
720	!
721	IF (nexit.ne.1) THEN
722	kinfo = CLIM_FastExit
723	WRITE(nulprt,FMT='(A)') 'Put - should not be called'
724	GO TO 1010
725	ENDIF
726	kinfo = PRISM_Ok
727	lg_dgfield = .false.
728	!
729	!* 1. check for this port in my list
730	! ---------------------------------
731	!
732	!
733	! If the user indicated in the namcouple that the field must be
734	! accumulated or averaged (keyword 'AVERAGE' or 'ACCUMUL' at the
735	! end of the field 2nd line), do the local transformations.
736	!
737	IF (ig_def_trans(iport) .EQ. ip_instant) THEN
738	cl_str = 'inst(ident(X))'
739	rg_field_trans(:,iport) = rd_field (:)
740	ELSEIF (ig_def_trans(iport) .eq. ip_average .or. &
741	ig_def_trans(iport) .EQ. ip_accumul .OR. &
742	ig_def_trans(iport) .EQ. ip_min .OR. &
743	ig_def_trans(iport) .EQ. ip_max) THEN
744	IF (ig_number(iport) .EQ. 0) rg_field_trans(:,iport) = 0
745	il_nbin = myport(4,iport)
746	il_nbout = il_nbin
747	cl_topps = 'ave, inst, t_sum, t_min, t_max'
748	IF (ig_def_trans(iport) .EQ. ip_average) THEN
749	cl_str = 'ave(ident(X))'
750	ELSEIF (ig_def_trans(iport) .EQ. ip_accumul) THEN
751	cl_str = 't_sum(ident(X))'
752	ELSEIF (ig_def_trans(iport) .EQ. ip_min) THEN
753	cl_str = 't_min(ident(X))'
754	ELSEIF (ig_def_trans(iport) .EQ. ip_max) THEN
755	cl_str = 't_max(ident(X))'
756	ENDIF
757	CALL buildop (cl_str,cl_topps,cl_tmp_topp,ip_nbopp_max, &
758	ip_missing_val,cl_tmp_sopp,rl_tmp_scal,il_nbopp)
759
760	CALL mathop (cl_tmp_sopp(1), il_nbin, rd_field, ip_missing_val, &
761	ip_nbindex, il_nindex, rl_tmp_scal(1), il_nbout, &
762	rl_field_aux)
763
764	IF ((cl_tmp_topp(:LEN_TRIM(cl_tmp_topp)) .NE. 'inst')) &
765	CALL moycum(cl_tmp_topp, il_nbin, rg_field_trans(:,iport), &
766	rl_field_aux, ig_number(iport))
767	ig_number(iport) = ig_number(iport) + 1
768	IF (MOD(il_newtime,ig_def_freq(iport)) .EQ. 0) THEN
769	ig_number(iport) = 0
770	DO ib = 1, myport(4,iport)
771	rd_field(ib) = rg_field_trans(ib,iport)
772	ENDDO
773	ENDIF
774	kinfo = PRISM_LocTrans
775	ENDIF
776	!
777	!* Test if field must be written to restart file i.e.
778	!* - current time is time at the end of simulation +
779	!* - lag of current field is greater 0
780	!
781	IF (il_newtime.eq.ig_ntime.and.ig_def_lag(iport).gt.0) THEN
782	!ac
783	IF (ig_def_state(iport) .ne. ip_output) THEN
784	!ac
785	!
786	!* Note: A model can have several restart files but same restart
787	!* file can't be used by different models
788	!
789	IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
790	CALL write_filer4(rd_field,cports(iport),iport)
791	ELSE
792	CALL write_file_parar4(rd_field,cports(iport),iport)
793	ENDIF
794	kinfo = PRISM_ToRest
795	!ac
796	ENDIF
797	!ac
798	! Test if the current time is a coupling (or I/O) time
799	IF (mod(il_newtime,ig_def_freq(iport)).eq.0) THEN
800
801	#if !defined key_noIO
802	!* If the user indicated in the namcouple that the field is
803	!* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
804	!* at the end of the field 1st line), do the writing to file here, e.g.:
805	!ac
806	IF (ig_def_state(iport) .EQ. ip_output ) THEN
807	CALL psmile_write_4(iport,rd_field,il_newtime)
808	kinfo = PRISM_Output
809	ELSEIF (ig_def_state(iport) .eq. ip_expout .or. &
810	ig_def_state(iport) .EQ. ip_ignout) THEN
811	CALL psmile_write_4(iport,rd_field,il_newtime)
812	kinfo = PRISM_ToRestOut
813	ENDIF
814	!ac
815	#endif
816	ENDIF
817	ELSE
818	! Test if the current time is a coupling (or I/O) time
819	IF (mod(il_newtime,ig_def_freq(iport)).eq.0) THEN
820	!
821	#if !defined key_noIO
822	!* If the user indicated in the namcouple that the field is
823	!* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
824	!* at the end of the field 1st line), do the writing to file here, e.g.:
825	IF (ig_def_state(iport) .EQ. ip_output .OR. &
826	ig_def_state(iport) .eq. ip_expout .or. &
827	ig_def_state(iport) .EQ. ip_ignout) THEN
828	CALL psmile_write_4(iport,rd_field,il_newtime)
829	kinfo = PRISM_Output
830	ENDIF
831	#endif
832	!*
833	!* If the user indicated in the namcouple that the field is
834	!* a coupling field (keyword EXPORTED','EXPOUT','IGNORED' or 'IGNOUT'
835	!* at the end of the field 1st line),do the export here.
836	!*
837	IF (ig_def_state(iport) .eq. ip_expout .or. &
838	ig_def_state(iport) .eq. ip_exported .or. &
839	ig_def_state(iport) .eq. ip_ignored .or. &
840	ig_def_state(iport) .eq. ip_ignout .or. &
841	ig_def_state(iport) .eq. ip_auxilary) THEN
842	!
843	!* check for connected ports (in)
844	! ------------------------------
845	!
846	WRITE(nulprt,FMT='(A,A)') 'Put - ', cports(iport)
847	!
848	ityp = myport(2,iport)
849	ibyt = myport(3,iport)
850	!
851	DO ip=1,myport(5,iport)
852	!
853	ilk = myport(5+ip,iport)
854	imod = mylink(1,ilk)
855	itid = mylink(2,ilk)
856	itag = mylink(3,ilk) - il_newtime / ig_frqmin
857	iseg = mylink(4,ilk)
858	!
859	ilgb = 0
860	iposbuf = 0
861	DO is=1,iseg
862	ioff = mylink(4+2is-1,ilk) 2 + 1
863	il_len = mylink(4+2*is,ilk)
864	!
865	IF ( ityp .EQ. PRISM_Real ) THEN
866	CALL MPI_Pack ( rd_field(ioff), il_len, &
867	MPI_REAL,pkwork_field, ig_maxtype_field, iposbuf, &
868	mpi_comm, info )
869	ELSE
870	WRITE(nulprt,*)'Put - pb type incorrect ', ityp
871	kinfo = CLIM_BadType
872	GO TO 1010
873	ENDIF
874	ilgb = ilgb + il_len
875	ENDDO
876	IF (info.ne.0 .or. ilgb*ibyt .gt. ig_maxtype_field) THEN
877	kinfo = CLIM_Pack
878	WRITE(nulprt,FMT='(A,I3,I8,A)') &
879	'Put - pb pack<mpi ',info,ilgb*ibyt,'>'
880	ELSE
881	IF (lg_clim_bsend) THEN
882	!*
883	!* Buffered send
884	!* -> if fields are not sent and received in the same order, and
885	!* and on architectures on which MPI_Send is not implemented with a
886	!* mailbox (e.g. NEC SX5)
887	!*
888	CALL MPI_BSend ( pkwork_field, iposbuf, MPI_PACKED, &
889	itid, itag, mpi_comm, info )
890	ELSE
891	!*
892	!* Standard blocking send: To be used
893	!* -> if fields are necessarily sent and received in the same order,
894	!* -> or on architectures on which MPI_Send is implemented with a
895	!* mailbox (e.g. VPPs); in this case, make sure that your mailbox
896	!* size is large enough.
897	!
898	CALL MPI_Send ( pkwork_field, iposbuf, MPI_PACKED, &
899	itid, itag, mpi_comm, info )
900	!
901	ENDIF
902	!
903	IF (info.eq.CLIM_ok) THEN
904	isend = isend + 1
905	nbsend = nbsend + ilgb * ibyt
906	WRITE(nulprt,FMT='(A,I2,A,I6,A,I7,A,I2,A,I10,A)') &
907	'Put - <dest:',imod, &
908	'> <step:',il_newtime, &
909	'> <len:',ilgb, &
910	'> <type:',ibyt, &
911	'> <tag:',itag,'>'
912	ELSE
913	kinfo = CLIM_Pvm
914	WRITE(nulprt,FMT='(A,I3,A)') &
915	'Put - pb send <mpi ',info,'>'
916	ENDIF
917	ENDIF
918	!
919	ENDDO
920	!
921	IF (kinfo .EQ. PRISM_Output) THEN
922	kinfo = PRISM_SentOut
923	ELSE
924	kinfo = PRISM_Sent
925	ENDIF
926
927	WRITE(nulprt,FMT='(A,I3,A)') &
928	'Put r24- ',isend,' fields exported'
929	ENDIF
930	ENDIF
931	ENDIF
932	!
933	! ----------------------------------------------------------------
934	!
935	1010 CONTINUE
936	CALL FLUSH(nulprt)
937	RETURN
938	END SUBROUTINE prism_put_proto_r24
939	#endif
940	SUBROUTINE prism_put_proto_r28(id_port_id,kstep,rd_field_2d,kinfo)
941	!
942	!* * PRISM_put * PRISM 1.0
943	!
944	! purpose:
945	! --------
946	! give rd_field to Oasis or models connected to port id_port_id at the
947	! time kstep
948	!
949	! interface:
950	! ----------
951	! id_port_id : port number of the field
952	! kstep : current time in seconds
953	! rd_field : buffer of reals
954	! kinfo : output status
955	!
956	! lib mp:
957	! -------
958	! mpi-1
959	!
960	! author:
961	! -------
962	! Arnaud Caubel - Fecit (08/02 - created from CLIM_Export)
963	! ----------------------------------------------------------------
964	USE mod_kinds_model
965	USE mod_prism_proto
966	USE mod_comprism_proto
967	USE mathelp_psmile
968	IMPLICIT NONE
969	#include <mpif.h>
970	! ----------------------------------------------------------------
971	INTEGER (kind=ip_intwp_p) kstep, kinfo, id_port_id
972	REAL(kind=ip_double_p), DIMENSION(:,:) :: rd_field_2d
973	! ----------------------------------------------------------------
974	REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rd_field
975	INTEGER (kind=ip_intwp_p) il_newtime
976	INTEGER (kind=ip_intwp_p) info
977	INTEGER (kind=ip_intwp_p) isend, ip, iport, ilk, iseg, is, ilgb, &
978	imod, itid, itag, il_len, ioff, ityp, ibyt
979	INTEGER (kind=ip_intwp_p) iposbuf
980	INTEGER (kind=ip_intwp_p) :: ib, il_nbopp, il_nbin, il_nbout
981	INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbopp_max = 10
982	INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbindex=1
983	INTEGER (kind=ip_intwp_p) :: il_nindex(ip_nbindex)
984	REAL(kind=ip_double_p) :: rl_tmp_scal(ip_nbopp_max)
985	REAL(kind=ip_double_p),PARAMETER :: ip_missing_val=1.e20
986	REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rl_field_aux
987	CHARACTER(len=80) :: cl_topps, cl_str
988	CHARACTER(len=7) :: cl_tmp_topp, cl_tmp_sopp(ip_nbopp_max)
989	! ----------------------------------------------------------------
990	isend = 0
991	iport = -1
992	!
993	! Test if the field is defined in the namcouple and if its coupling period
994	! is not greater than the time of the simulation.
995
996	IF (ig_def_freq(id_port_id) .eq. 0 .or. &
997	ig_def_freq(id_port_id) .gt. ig_ntime) THEN
998	GOTO 1010
999	ENDIF
1000	! if a field exported at a certain time should match an import
1001	! at a time+lag, add the lag here; the lag is given by the user
1002	! in the namcouple at the end of the field 2nd line.
1003	IF (myport(1,id_port_id).eq.CLIM_Out) THEN
1004	iport=id_port_id
1005	il_newtime = kstep + ig_def_lag(iport)
1006	ENDIF
1007	IF (iport.lt.0) THEN
1008	kinfo = CLIM_BadPort
1009	WRITE(nulprt,FMT='(A,A)') &
1010	'Put - WARNING - Invalid port out: ', &
1011	cports(id_port_id)
1012	GO TO 1010
1013	ENDIF
1014
1015	rd_field(1:myport(4,id_port_id)) = RESHAPE (rd_field_2d(:,:), &
1016	(/myport(4,id_port_id)/))
1017	rl_field_aux(:)=0
1018	cl_tmp_sopp(:)=' '
1019	il_nindex(:)=0
1020	rl_tmp_scal(:)=0
1021	!
1022	!* 0. First check
1023	! --------------
1024	!
1025	IF (nexit.ne.1) THEN
1026	kinfo = CLIM_FastExit
1027	WRITE(nulprt,FMT='(A)') 'Put - should not be called'
1028	GO TO 1010
1029	ENDIF
1030	kinfo = PRISM_Ok
1031	lg_dgfield = .true.
1032	!
1033	!* 1. check for this port in my list
1034	! ---------------------------------
1035	!
1036	! isend = 0
1037	! iport = -1
1038	!
1039	!
1040	! Test if the field is defined in the namcouple and if its coupling period
1041	! is not greater than the time of the simulation.
1042	! IF (ig_def_freq(id_port_id) .eq. 0 .or. &
1043	! ig_def_freq(id_port_id) .gt. ig_ntime) THEN
1044	! GOTO 1010
1045	! ENDIF
1046	! if a field exported at a certain time should match an import
1047	! at a time+lag, add the lag here; the lag is given by the user
1048	! in the namcouple at the end of the field 2nd line.
1049	! IF (myport(1,id_port_id).eq.CLIM_Out) THEN
1050	! iport=id_port_id
1051	! il_newtime = kstep + ig_def_lag(iport)
1052	! ENDIF
1053	! IF (iport.lt.0) THEN
1054	! kinfo = CLIM_BadPort
1055	! WRITE(nulprt,FMT='(A,A)') &
1056	! 'Put - WARNING - Invalid port out: ', &
1057	! cports(id_port_id)
1058	! GO TO 1010
1059	! ENDIF
1060	!
1061	! If the user indicated in the namcouple that the field must be
1062	! accumulated or averaged (keyword 'AVERAGE' or 'ACCUMUL' at the
1063	! end of the field 2nd line), do the local transformations.
1064	!
1065	IF (ig_def_trans(iport) .EQ. ip_instant) THEN
1066	cl_str = 'inst(ident(X))'
1067	dg_field_trans(:,iport) = rd_field (:)
1068	ELSEIF (ig_def_trans(iport) .EQ. ip_average .OR. &
1069	ig_def_trans(iport) .EQ. ip_accumul .OR. &
1070	ig_def_trans(iport) .EQ. ip_min .OR. &
1071	ig_def_trans(iport) .EQ. ip_max) THEN
1072	IF (ig_number(iport) .EQ. 0) dg_field_trans(:,iport) = 0
1073	il_nbin = myport(4,iport)
1074	il_nbout = il_nbin
1075	cl_topps = 'ave, inst, t_sum, t_min, t_max'
1076	IF (ig_def_trans(iport) .EQ. ip_average) THEN
1077	cl_str = 'ave(ident(X))'
1078	ELSEIF (ig_def_trans(iport) .EQ. ip_accumul) THEN
1079	cl_str = 't_sum(ident(X))'
1080	ELSEIF (ig_def_trans(iport) .EQ. ip_min) THEN
1081	cl_str = 't_min(ident(X))'
1082	ELSEIF (ig_def_trans(iport) .EQ. ip_max) THEN
1083	cl_str = 't_max(ident(X))'
1084	ENDIF
1085	CALL buildop (cl_str,cl_topps,cl_tmp_topp,ip_nbopp_max, &
1086	ip_missing_val,cl_tmp_sopp,rl_tmp_scal,il_nbopp)
1087
1088	CALL mathop (cl_tmp_sopp(1), il_nbin, rd_field, ip_missing_val, &
1089	ip_nbindex, il_nindex, rl_tmp_scal(1), il_nbout, &
1090	rl_field_aux)
1091
1092	IF ((cl_tmp_topp(:LEN_TRIM(cl_tmp_topp)) .NE. 'inst')) &
1093	CALL moycum(cl_tmp_topp, il_nbin, dg_field_trans(:,iport), &
1094	rl_field_aux, ig_number(iport))
1095	ig_number(iport) = ig_number(iport) + 1
1096	IF (MOD(il_newtime,ig_def_freq(iport)) .EQ. 0) THEN
1097	ig_number(iport) = 0
1098	DO ib = 1, myport(4,iport)
1099	rd_field(ib) = dg_field_trans(ib,iport)
1100	ENDDO
1101	ENDIF
1102	kinfo = PRISM_LocTrans
1103	ENDIF
1104	!
1105	!* Test if field must be written to restart file i.e.
1106	!* - current time is time at the end of simulation +
1107	!* - lag of current field is greater from 0
1108	!
1109	IF (il_newtime.eq.ig_ntime.and.ig_def_lag(iport).gt.0) THEN
1110	!ac
1111	IF (ig_def_state(iport) .ne. ip_output) THEN
1112	!ac
1113	!
1114	!* Note: A model can have several restart files but same restart
1115	!* file can't be used by different models
1116	!
1117	IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
1118	CALL write_filer8(rd_field,cports(iport),iport)
1119	ELSE
1120	CALL write_file_parar8(rd_field,cports(iport),iport)
1121	ENDIF
1122	kinfo = PRISM_ToRest
1123	!ac
1124	ENDIF
1125	!ac
1126	! Test if the current time is a coupling (or I/O) time
1127	IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN
1128
1129	#if !defined key_noIO
1130	!* If the user indicated in the namcouple that the field is
1131	!* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
1132	!* at the end of the field 1st line), do the writing to file here, e.g.:
1133	!ac
1134	IF (ig_def_state(iport) .EQ. ip_output ) THEN
1135	CALL psmile_write_8(iport,rd_field,il_newtime)
1136	kinfo = PRISM_Output
1137	ELSEIF (ig_def_state(iport) .eq. ip_expout .or. &
1138	ig_def_state(iport) .EQ. ip_ignout) THEN
1139	CALL psmile_write_8(iport,rd_field,il_newtime)
1140	kinfo = PRISM_ToRestOut
1141	ENDIF
1142	!ac
1143	! IF (ig_def_state(iport) .EQ. ip_output .OR. &
1144	! ig_def_state(iport) .eq. ip_expout .or. &
1145	! ig_def_state(iport) .EQ. ip_ignout) THEN
1146	! CALL psmile_write_8(iport,rd_field,il_newtime)
1147	! kinfo = PRISM_ToRestOut
1148	! ENDIF
1149	#endif
1150	ENDIF
1151	ELSE
1152
1153	! Test if the current time is a coupling (or I/O) time
1154	IF (mod(il_newtime,ig_def_freq(iport)).eq.0) THEN
1155	!
1156	#if !defined key_noIO
1157	!* If the user indicated in the namcouple that the field is
1158	!* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT'
1159	!* at the end of the field 1st line), do the writing to file here, e.g.:
1160	IF (ig_def_state(iport) .EQ. ip_output .OR. &
1161	ig_def_state(iport) .eq. ip_expout .or. &
1162	ig_def_state(iport) .eq. ip_ignout) THEN
1163	call psmile_write_8(iport,rd_field,il_newtime)
1164	kinfo = PRISM_Output
1165	ENDIF
1166	#endif
1167	!*
1168	!* If the user indicated in the namcouple that the field is
1169	!* a coupling field (keyword EXPORTED','EXPOUT','IGNORED' or 'IGNOUT'
1170	!* at the end of the field 1st line),do the export here.
1171	!*
1172	IF (ig_def_state(iport) .eq. ip_expout .or. &
1173	ig_def_state(iport) .eq. ip_exported .or. &
1174	ig_def_state(iport) .eq. ip_ignored .or. &
1175	ig_def_state(iport) .eq. ip_ignout .or. &
1176	ig_def_state(iport) .eq. ip_auxilary) THEN
1177	!
1178	!* check for connected ports (in)
1179	! ------------------------------
1180	!
1181	WRITE(nulprt,FMT='(A,A)') 'Put - ', cports(iport)
1182	!
1183	ityp = myport(2,iport)
1184	ibyt = myport(3,iport)
1185	!
1186	DO ip=1,myport(5,iport)
1187	!
1188	ilk = myport(5+ip,iport)
1189	imod = mylink(1,ilk)
1190	itid = mylink(2,ilk)
1191	itag = mylink(3,ilk) - il_newtime / ig_frqmin
1192	iseg = mylink(4,ilk)
1193	!
1194	ilgb = 0
1195	iposbuf = 0
1196	DO is=1,iseg
1197	ioff = mylink(4+2*is-1,ilk) + 1
1198	il_len = mylink(4+2*is,ilk)
1199	!
1200	! IF ( ityp .EQ. PRISM_Real .or. ityp .EQ. PRISM_Double) THEN
1201	IF ( ityp .EQ. PRISM_Real ) THEN
1202	CALL MPI_Pack(rd_field(ioff),il_len, &
1203	MPI_DOUBLE_PRECISION, &
1204	pkwork_field, ig_maxtype_field, iposbuf, &
1205	mpi_comm, info )
1206	ELSE
1207	WRITE(nulprt,*)'Put - pb type incorrect ', ityp
1208	kinfo = CLIM_BadType
1209	GO TO 1010
1210	ENDIF
1211	ilgb = ilgb + il_len
1212	ENDDO
1213	IF (info.ne.0 .or. ilgb*ibyt .gt. ig_maxtype_field) THEN
1214	kinfo = CLIM_Pack
1215	WRITE(nulprt,FMT='(A,I3,I8,A)') &
1216	'Put - pb pack<mpi ',info,ilgb*ibyt,'>'
1217	ELSE
1218	IF (lg_clim_bsend) THEN
1219	!*
1220	!* Buffered send
1221	!* -> if fields are not sent and received in the same order, and
1222	!* and on architectures on which MPI_Send is not implemented with a
1223	!* mailbox (e.g. NEC SX5)
1224	!*
1225	CALL MPI_BSend ( pkwork_field, iposbuf, &
1226	MPI_PACKED, itid, itag, mpi_comm, info )
1227	ELSE
1228	!*
1229	!* Standard blocking send: To be used
1230	!* -> if fields are necessarily sent and received in the same order,
1231	!* -> or on architectures on which MPI_Send is implemented with a
1232	!* mailbox (e.g. VPPs); in this case, make sure that your mailbox
1233	!* size is large enough.
1234	!
1235	CALL MPI_Send ( pkwork_field, iposbuf, &
1236	MPI_PACKED, itid, itag, mpi_comm, info )
1237	!
1238	ENDIF
1239	!
1240	IF (info.eq.CLIM_ok) THEN
1241	isend = isend + 1
1242	nbsend = nbsend + ilgb * ibyt
1243	WRITE(nulprt,FMT='(A,I2,A,I6,A,I7,A,I2,A,I10,A)') &
1244	'Put - <dest:',imod, &
1245	'> <step:',il_newtime, &
1246	'> <len:',ilgb, &
1247	'> <type:',ibyt, &
1248	'> <tag:',itag,'>'
1249	ELSE
1250	kinfo = CLIM_Pvm
1251	WRITE(nulprt,FMT='(A,I3,A)') &
1252	'Put - pb send <mpi ',info,'>'
1253	ENDIF
1254	ENDIF
1255	!
1256	ENDDO
1257	!
1258	IF (kinfo .EQ. PRISM_Output) THEN
1259	kinfo = PRISM_SentOut
1260	ELSE
1261	kinfo = PRISM_Sent
1262	ENDIF
1263
1264	WRITE(nulprt,FMT='(A,I3,A)') &
1265	'Put r28 - ',isend,' fields exported'
1266	ENDIF
1267	ENDIF
1268	ENDIF
1269	!
1270	! ----------------------------------------------------------------
1271	!
1272	1010 CONTINUE
1273	CALL FLUSH(nulprt)
1274	RETURN
1275	END SUBROUTINE prism_put_proto_r28
1276
1277	end module mod_prism_put_proto
1278

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

Context Navigation

source: CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_put_proto.F90 @ 1677

Download in other formats: