Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

givfld.F @ 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: 24.7 KB

Line
1	SUBROUTINE givfld (kindex, kfield, kiter)
2	C****
3	C *****************************
4	C * OASIS ROUTINE - LEVEL 1 *
5	C * ------------- ------- *
6	C *****************************
7	C
8	C**** givfld - writing routine
9	C
10	C
11	C Purpose:
12	C -------
13	C Write out coupling fields for iteration kiter
14	C
15	C** Interface:
16	C ---------
17	C CALL givfld (kindex, kfield, kiter)
18	C
19	C Input:
20	C -----
21	C kindex : current active fields index array
22	C kfield : current active fields total number
23	C kiter : iteration number
24	C
25	C Output:
26	C ------
27	C None
28	C
29	C Workspace:
30	C ---------
31	C None
32	C
33	C Externals:
34	C ---------
35	C PIPE_Send, CLIM_Export, SVIPC_write
36	C
37	C Reference:
38	C ---------
39	C See OASIS manual (1995)
40	C
41	C History:
42	C -------
43	C Version Programmer Date Description
44	C ------- ---------- ---- -----------
45	C 2.0 L. Terray 95/09/01 created
46	C 2.1 L. Terray 96/08/07 modified: addition of cstate
47	C to prevent field transfer
48	C 2.2 S. Valcke 97/08/22 added: introduction of SVIPC
49	C 2.2 L. Terray 97/12/14 added: test on mode info +
50	C general cleaning
51	C 2.3 S. Valcke 99/04/30 added: printing levels
52	C 2.3 L. Terray 99/09/15 added: GMEM branch
53	C
54	C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
55	C
56	C* -----------------Include files and USE of modules---------------------------
57	C
58	USE mod_kinds_oasis
59	#if defined use_comm_MPI1 \|\| defined use_comm_MPI2 \|\| !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
60	USE mod_clim
61	#endif
62	USE mod_parameter
63	USE mod_string
64	USE mod_analysis
65	USE mod_memory
66	USE mod_sipc
67	USE mod_unitncdf
68	USE mod_experiment
69	USE mod_timestep
70	USE mod_unit
71	USE mod_hardware
72	USE mod_label
73	USE mod_calendar
74	USE mod_printing
75	INCLUDE 'netcdf.inc'
76	C
77	C* ---------------------------- Argument declarations -------------------
78	C
79	INTEGER (kind=ip_intwp_p) kindex(kfield)
80	C
81	C* ---------------------------- Local declarations ----------------------
82	C
83	INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: info,
84	$ iflag
85	INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: idimlon,
86	$ idimlat, ivarid
87	INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: ilongrd,
88	$ ilatgrd
89	CHARACTER*8 clname, clfic, clstat, clwork, clstrg
90	CHARACTER*53 clabel
91	CHARACTER*32 cl_att_name
92	INTEGER (kind=ip_intwp_p) itime(3)
93	INTEGER (kind=ip_intwp_p) ist(3), icnt(3), ivardim(3)
94	INTEGER (kind=ip_intwp_p) idimtime, il_timevarid
95	INTEGER (kind=ip_intwp_p) il_nb_att, il_ind_att
96	CHARACTER*4 clon, clat
97	C
98	C* ---------------------------- Poema verses ----------------------------
99	C
100	C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
101	C
102	C* 1. Allocation and initialization
103	C -----------------------------
104	C
105	IF (nlogprt .GE. 2) THEN
106	WRITE (UNIT = nulou,FMT = *) ' '
107	WRITE (UNIT = nulou,FMT = *) ' '
108	WRITE (UNIT = nulou,FMT = *)
109	$ ' ROUTINE givfld - Level 1'
110	WRITE (UNIT = nulou,FMT = *)
111	$ ' ************ *****'
112	WRITE (UNIT = nulou,FMT = *) ' '
113	WRITE (UNIT = nulou,FMT = *) ' Give coupling fields'
114	WRITE (UNIT = nulou,FMT = *) ' '
115	WRITE (UNIT = nulou,FMT = *) ' '
116	ENDIF
117	infos = CLIM_Ok
118	itime(:)=0
119	ist(:)=0
120	icnt(:)=0
121	iflags = 0
122	istop = 0
123	imrca = 0
124	imrcb = 0
125	ALLOCATE (iflag(ig_nfield))
126	ALLOCATE (info(ig_nfield))
127	ALLOCATE (idimlon(ig_nfield))
128	ALLOCATE (idimlat(ig_nfield))
129	ALLOCATE (ivarid(ig_nfield))
130	ALLOCATE (ilongrd(ig_nfield))
131	ALLOCATE (ilatgrd(ig_nfield))
132	CALL izero (iflag, ig_nfield)
133	CALL izero (info, ig_nfield)
134	idimlon(:)=0
135	idimlat(:)=0
136	ivarid(:)=0
137	ilongrd(:)=0
138	ilatgrd(:)=0
139	C
140	C
141	C* 1.5 Create binary or netcdf output files for PIPE or NONE technique
142	C ----------------------------------------------------------------
143	C
144	IF (kiter .eq. 0 .or. cchan .eq. 'PIPE') THEN
145	IF (cchan .eq. 'PIPE' .or. cchan .eq. 'NONE' ) THEN
146	DO 120 jf = 1, kfield
147	iloc = kindex(jf)
148	isamefic=0
149	DO 125 jj = 1, jf-1
150	ilocp=kindex(jj)
151	IF (nluout(iloc) .eq. nluout(ilocp)) THEN
152	isamefic=isamefic+1
153	nc_outid(jf) = nc_outid(jj)
154	ENDIF
155	125 END DO
156	IF (isamefic .lt. 1) THEN
157	iunit = nluout(iloc)
158	clfic = cficout(iloc)
159	IF (lncdfrst) THEN
160	istatus=NF_CREATE(clfic, NF_CLOBBER, nc_outid(jf))
161	IF (istatus .ne. NF_NOERR) THEN
162	CALL prtout
163	$ ('Cannot create netcdf output file for field ',iloc,1)
164	CALL HALTE('STOP in givfld')
165	ENDIF
166	C
167	C For each new file created define all possible
168	C dimensions and coordinate variables
169	C
170	DO 130 jfint=1, kfield
171	ilocint = kindex(jfint)
172	isamedimlon = 0
173	ilon = 0
174	isamedimlat = 0
175	ilat = 0
176	isamegrd = 0
177	igrd = 0
178	C
179	C Test if same output file
180	IF (nluout(ilocint) .eq. iunit) THEN
181	C
182	C Loop on all previous fields
183	DO 135 jfintp=1, jfint-1
184	ilocintp=kindex(jfintp)
185	C
186	C Test if same x dimension
187	IF(nluout(ilocint) .eq. nluout(ilocintp)
188	$ .and. nlonaf(ilocint) .eq. nlonaf(ilocintp)) THEN
189	isamedimlon = isamedimlon + 1
190	idimlon(jfint) = idimlon(jfintp)
191	ENDIF
192	C
193	C Test if same y dimension
194	IF(nluout(ilocint) .eq. nluout(ilocintp)
195	$ .and. nlataf(ilocint) .eq. nlataf(ilocintp)) THEN
196	isamedimlat = isamedimlat + 1
197	idimlat(jfint) = idimlat(jfintp)
198	ENDIF
199	C
200	C Test IF same grid
201	IF(nluout(ilocint).eq.nluout(ilocintp) .and.
202	$ cficaf(ilocint) .eq. cficaf(ilocintp)) THEN
203	isamegrd = isamegrd + 1
204	ilongrd(jfint) = ilongrd(jfintp)
205	ilatgrd(jfint) = ilatgrd(jfintp)
206	ENDIF
207	135 CONTINUE
208	C
209	C Define x dimension if not already defined
210	IF (isamedimlon .lt. 1) THEN
211	ilon=ilon+1
212	clon='lon'//char(ilon+48)
213	CALL hdlerr(NF_DEF_DIM(nc_outid(jf), clon,
214	$ nlonaf(ilocint), idimlon(jfint)),'givfld')
215	ENDIF
216	C
217	C Define y dimension if not already defined
218	IF (isamedimlat .lt. 1) THEN
219	ilat=ilat+1
220	clat='lat'//char(ilon+48)
221	CALL hdlerr(NF_DEF_DIM(nc_outid(jf), clat,
222	$ nlataf(ilocint), idimlat(jfint)),'givfld')
223	ENDIF
224	C
225	C Define t dimension and variable at first
226	C time step if necessary
227	CALL hdlerr(NF_DEF_DIM(nc_outid(jf),
228	$ nc_invartime_name,NF_UNLIMITED,
229	$ idimtime),'givfld')
230	CALL hdlerr(NF_DEF_VAR(nc_outid(jf),
231	$ nc_invartime_name,n_reaty,1,idimtime,
232	$ il_timevarid),'givfld')
233	icount = 80
234	C
235	C Copy time variable attributes
236	C
237	IF ( nitfn .gt. 0) THEN
238	CALL hdlerr(NF_OPEN(cficinp(1),NF_NOWRITE,
239	$ nc_inpid(1)),'givfld')
240	CALL hdlerr(NF_INQ_VARNATTS(nc_inpid(1),
241	$ nc_invartimeid, il_nb_att), 'givfld')
242	DO il_ind_att=1, il_nb_att
243	CALL hdlerr(NF_INQ_ATTNAME(nc_inpid(1),
244	$ nc_invartimeid, il_ind_att,
245	$ cl_att_name), 'givfld')
246	CALL hdlerr(NF_COPY_ATT(nc_inpid(1),
247	$ nc_invartimeid, cl_att_name,
248	$ nc_outid(jf), il_timevarid)
249	$ , 'givfld')
250	END DO
251	CALL hdlerr(NF_CLOSE(nc_inpid(1)))
252	ENDIF
253	C
254	C Create coord. variable IF not already created
255	IF (isamegrd .lt. 1) THEN
256	ivardim(1)=idimlon(jfint)
257	ivardim(2)=idimlat(jfint)
258	clwork = cficaf(jfint)
259	icount = ilenstr(clwork,jpeight)
260	clstrg = clwork(1:icount)//cglonsuf
261	CALL hdlerr(NF_DEF_VAR(nc_outid(jf),
262	$ clstrg,n_reaty,2,ivardim,ilongrd(jfint)),'givfld')
263	clstrg = clwork(1:icount)//cglatsuf
264	CALL hdlerr(NF_DEF_VAR(nc_outid(jf),
265	$ clstrg,n_reaty,2,ivardim,ilatgrd(jfint)),'givfld')
266	ENDIF
267	ENDIF
268	130 CONTINUE
269	ELSE
270	OPEN (UNIT = iunit,FILE = clfic,STATUS = 'UNKNOWN',
271	$ FORM = 'UNFORMATTED',IOSTAT = iost)
272	IF (iost .ne. 0) THEN
273	CALL prtout
274	$ ('Cannot create binary output file for field ',iloc,1)
275	CALL HALTE('STOP in givfld')
276	ENDIF
277	ENDIF
278	ENDIF
279
280	C
281	C* Create the jf netcdf variables
282	C
283	IF (lncdfrst) THEN
284	ivardim(1)=idimlon(jf)
285	ivardim(2)=idimlat(jf)
286	C IF ( nitfn .gt. 0) THEN
287	ivardim(3)=idimtime
288	CALL hdlerr(NF_DEF_VAR(nc_outid(jf), cnamout(iloc),
289	$ n_reaty, 3, ivardim, ivarid(jf)), 'givfld')
290	C ELSE
291	C CALL hdlerr(NF_DEF_VAR(nc_outid(jf), cnamout(iloc),
292	C $ n_reaty, 2, ivardim, ivarid(jf)), 'givfld')
293	C ENDIF
294	ENDIF
295	120 CONTINUE
296	C
297	C* Define header if info mode is on :
298	C experiment name, initial date, iteration number, time since start
299	C
300	IF (lmodinf) THEN
301	itime(1) = ndate
302	itime(2) = kiter
303	itime(3) = kiter * nstep
304	IF (nlogprt .GE. 2) THEN
305	WRITE (UNIT = nulou,FMT = *)
306	$ ' Encapsulated data for current field is :'
307	CALL prcout ('Experiment name', cjobnam, 1)
308	CALL prtout ('Initial date', itime(1), 2)
309	CALL prtout ('Iteration number', itime(2), 2)
310	CALL prtout ('Time since start', itime(3), 2)
311	ENDIF
312	ENDIF
313	C
314	IF (lncdfrst) THEN
315	C
316	C Loop on all fields for this iteration
317	DO 140 jf = 1, kfield
318	iloc=kindex(jf)
319	isamefic=0
320	C
321	C Test IF define mode has been already left.
322	DO 145 jj = 1, jf-1
323	IF (nc_outid(jf) .eq. nc_outid(jj)) THEN
324	isamefic=isamefic+1
325	ENDIF
326	145 CONTINUE
327	C
328	IF (isamefic .lt. 1) THEN
329	C
330	C* Put header as global attribute IF lmodinf
331	WRITE(nulou,*)'lmodinf=', lmodinf
332	IF (lmodinf) THEN
333	CALL hdlerr(NF_PUT_ATT_TEXT(nc_outid(jf),
334	$ NF_GLOBAL,'Experiment_name',4,cjobnam),'givfld')
335	CALL hdlerr(NF_PUT_ATT_INT(nc_outid(jf),NF_GLOBAL
336	$ ,'Initial_date',NF_INT,1,itime(1)),'givfld')
337	CALL hdlerr(NF_PUT_ATT_INT(nc_outid(jf),NF_GLOBAL
338	$ ,'Iteration_number',NF_INT,1,itime(2)),'givfld')
339	CALL hdlerr(NF_PUT_ATT_INT(nc_outid(jf),NF_GLOBAL
340	$ ,'Time_since_start',NF_INT,1,itime(3)),'givfld')
341	ENDIF
342	C
343	C* Leave define mode for netcdf files
344	istatus=NF_ENDDEF(nc_outid(jf))
345	IF(istatus .ne. NF_NOERR) THEN
346	CALL prtout
347	$ ('Cannot leave define mode for output file for field ',iloc,1)
348	CALL HALTE('STOP in givfld')
349	ENDIF
350	ENDIF
351	C
352	C Test IF coordinate variables have already been put.
353	isamegrd = 0
354	iadrnew = nadrnew_grid(jf)
355	isiznew = nsiznew(jf)
356	DO 155 jj = 1, jf-1
357	ilocp=kindex(jj)
358	IF (nluout(iloc) .eq. nluout(ilocp) .and. cficaf(iloc)
359	$ .eq. cficaf(ilocp)) isamegrd=isamegrd+1
360	155 CONTINUE
361	C
362	C If not, put coordinate variable to file jf
363	IF (isamegrd .lt. 1) THEN
364	ist(1)=1 ; ist(2)=1
365	icnt(1)=nlonaf(iloc) ; icnt(2)=nlataf(iloc)
366	IF (n_reaty .eq. NF_FLOAT) THEN
367	istatus=NF_PUT_VARA_REAL
368	$ (nc_outid(jf),ilongrd(jf),ist, icnt,
369	$ xgrnew(iadrnew:iadrnew+isiznew-1))
370
371	ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
372	istatus=NF_PUT_VARA_DOUBLE
373	$ (nc_outid(jf),ilongrd(jf),ist, icnt,
374	$ xgrnew(iadrnew:iadrnew+isiznew-1))
375	ENDIF
376	IF (n_reaty .eq. NF_FLOAT) THEN
377	istatus=NF_PUT_VARA_REAL
378	$ (nc_outid(jf),ilatgrd(jf),ist, icnt,
379	$ ygrnew(iadrnew:iadrnew+isiznew-1))
380
381	ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
382	istatus=NF_PUT_VARA_DOUBLE
383	$ (nc_outid(jf),ilatgrd(jf),ist, icnt,
384	$ ygrnew(iadrnew:iadrnew+isiznew-1))
385	ENDIF
386	ENDIF
387	140 CONTINUE
388	ENDIF
389	C
390	ENDIF
391	C
392	ENDIF
393	C
394	C* 2. Loop on active fields for iteration kiter
395	C -----------------------------------------
396	C
397	!$omp parallel do default (shared)
398	!$omp+ private (jf,iloc,iadrnew,isiznew,clname,ilabel)
399	!$omp+ private (clabel,iunit,clstat)
400	!$omp+ reduction (+:infos)
401
402	DO 210 jf = 1, kfield
403	C
404	C* Assign local variables
405	C
406	iloc = kindex(jf)
407	iadrnew = nadrnew(iloc)
408	isiznew = nsiznew(iloc)
409	clname = cnamout(iloc)
410	ilabel = numlab(iloc)
411	clabel = cfldlab(ilabel)
412	iunit = nluout(iloc)
413	clstat = cstate(iloc)
414	C
415	C* Test if field must be exported
416	C
417	IF (clstat .EQ. 'EXPORTED') THEN
418	C
419	C* Print field name
420	C
421	IF (nlogprt .GE. 1) THEN
422	CALL prcout('Writing of field : ', clname, 2)
423	CALL prcout('Field definition : ', clabel, 2)
424	ENDIF
425
426	C
427	C* - Give coupling fields
428	C
429	C* PIPE or NONE case
430	C
431	IF (cchan .EQ. 'PIPE' .OR. cchan .EQ. 'NONE') THEN
432	C
433	IF (lncdfrst) THEN
434	CEM
435	C Get variables ID
436	CEM
437	istatus=NF_INQ_VARID(nc_outid(jf),clname,
438	$ ivarid(jf))
439	istatus=NF_INQ_VARID(nc_outid(jf),nc_invartime_name,
440	$ il_timevarid)
441	ist(1)=1 ; ist(2)=1 ; ist(3)=1+kiter
442	icnt(1)=nlonaf(iloc) ; icnt(2)=nlataf(iloc)
443	icnt(3)=1
444	IF (n_reaty .eq. NF_FLOAT) THEN
445	CALL hdlerr(NF_PUT_VARA_REAL
446	$ (nc_outid(jf),il_timevarid,ist(3),
447	$ icnt(3),r_time_val), 'givfld')
448	istatus=NF_PUT_VARA_REAL
449	$ (nc_outid(jf),ivarid(jf),ist, icnt,
450	$ fldnew(iadrnew:iadrnew+isiznew-1))
451	IF (istatus .ne. 0) THEN
452	iflag(jf) = istatus
453	iflags= iflags + 1
454	ENDIF
455
456	ELSE IF (n_reaty .eq. NF_DOUBLE) THEN
457	CALL hdlerr(NF_PUT_VARA_DOUBLE
458	$ (nc_outid(jf),il_timevarid,ist(3),
459	$ icnt(3),rtime_val), 'givfld')
460	istatus=NF_PUT_VARA_DOUBLE
461	$ (nc_outid(jf),ivarid(jf),ist, icnt,
462	$ fldnew(iadrnew:iadrnew+isiznew-1))
463	IF (istatus .ne. 0) THEN
464	iflag(jf) = istatus
465	iflags= iflags + 1
466	ENDIF
467	ENDIF
468	ELSE
469	C* Write new field on unit iunit with header if required
470	C
471	IF (lmodinf) THEN
472	CALL locwrith (clname, cjobnam, itime,
473	$ fldnew(iadrnew), isiznew, iunit, iflag(jf))
474	ELSE
475	CALL locwrite (clname, fldnew(iadrnew), isiznew,
476	$ iunit, iflag(jf))
477	ENDIF
478	iflags = iflags + iflag(jf)
479	ENDIF
480	ELSE IF (cchan .EQ. 'SIPC' .OR. cchan .EQ. 'GMEM') THEN
481	C
482	C* SIPC case
483	C
484	#if defined use_comm_SIPC \|\| defined use_comm_GMEM
485	C
486	ipbytecha=kind('A')
487	ipbyteint=kind(itime)
488	ipbyterea=kind(fldnew)
489	C
490	C* Write encapsulated infos in field-specific shared memory pool
491	C
492	IF (lmodinf) THEN
493	isizeout = 3*ipbytecha
494	CALL SVIPC_write(mpoolidou(iloc), cjobnam
495	$ , isizeout, imrca)
496	isizeout = 3*ipbyteint
497	CALL SVIPC_write(mpoolidou(iloc), itime
498	$ ,isizeout,imrcb)
499	C
500	C* Find error if any
501	C
502	IF (imrca .LT. 0 .OR. imrcb .LT. 0) THEN
503	CALL prcout
504	$ ('Problem in writing encapsulated infos for field', clname, 1)
505	istop = 1
506	ENDIF
507	IF (nlogprt .GE. 2) THEN
508	CALL prcout
509	$ ('Wrote encapsulated infos in pool for field',clname,1)
510	ENDIF
511	ENDIF
512	C
513	C* Write part of macro array in field-specific shared memory pool
514	C
515	isizeout = isiznew * ipbyterea
516	IF (nlogprt .GE. 2) THEN
517	WRITE(UNIT = nulou, FMT = *)
518	$ 'Writing field data to pool = ',mpoolidou(iloc)
519	ENDIF
520	CALL SVIPC_write(mpoolidou(iloc),
521	$ fldnew(iadrnew), isizeout, imrc)
522	C
523	C* Find error and stop if any
524	C
525	IF (imrc .LT. 0) THEN
526	CALL prcout
527	$ ('Problem in writing field in SHM pool:',clname,1)
528	istop = 1
529	ELSE IF (nlogprt .GE. 2) THEN
530	CALL prcout
531	$ ('Wrote field in SHM pool:', clname, 1)
532	ENDIF
533	C
534	C* CLIM case
535	C
536	#endif
537	ELSE IF (cchan .EQ. 'MPI2' .or. cchan .EQ. 'MPI1' ) THEN
538	#if defined use_comm_MPI1 \|\| defined use_comm_MPI2 \|\| !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
539	C
540	C* Write new field on port clname
541	C
542	!$omp critical
543	CALL CLIM_Export
544	$ (ig_portout_id(iloc), kiter*nstep,
545	$ fldnew(iadrnew), info(jf))
546	infos = infos + info(jf)
547	!$omp end critical
548	#endif
549	ELSE
550	CALL prcout
551	$ ('Wrong CHANNEL option for field', clname, 1)
552	ENDIF
553	ELSE IF (clstat .EQ. 'AUXILARY') THEN
554	iflag(jf) = 0
555	info(jf) = 0
556	ENDIF
557	210 CONTINUE
558	C
559	IF (cchan .EQ. 'MPI2' .or. cchan .EQ. 'MPI1' ) THEN
560	C*
561	#if defined use_comm_MPI1 \|\| defined use_comm_MPI2 \|\| !defined use_comm_MPI1 && !defined use_comm_MPI2 && !defined use_comm_SIPC && !defined use_comm_GMEM && !defined use_comm_PIPE && !defined use_comm_NONE
562	C* Stop if problem in writing in CLIM case
563	C
564	IF (infos .NE. CLIM_Ok) THEN
565	DO 220 jf = 1, kfield
566	IF (info(jf) .NE. CLIM_Ok) THEN
567	CALL prcout
568	$ ('WARNING: problem in writing field on port',
569	$ clname, 1)
570	CALL prtout
571	$ ('error code number', info(jf), 2)
572	ENDIF
573	220 CONTINUE
574	CALL HALTE ('STOP in givfld')
575	ENDIF
576	C
577	#endif
578	ELSE IF (cchan .EQ. 'PIPE' .or. cchan .eq. 'NONE') THEN
579	#if defined use_comm_PIPE \|\| defined use_comm_NONE
580	C* Stop if problem in writing in PIPE or NONE case
581	C
582	IF (iflags .NE. 0) THEN
583	DO 230 jf = 1, kfield
584	IF (iflag(jf) .NE. 0) THEN
585	iloc = kindex(jf)
586	iunit = nluout(iloc)
587	clname = cnamout(iloc)
588	CALL prcout
589	$ ('WARNING: problem in writing field',
590	$ clname, 1)
591	CALL prtout
592	$ ('Error writing on logical unit', iunit, 2)
593	ENDIF
594	230 CONTINUE
595	CALL HALTE ('STOP in givfld')
596	ENDIF
597	C
598	#endif
599	ELSE IF (cchan .EQ. 'SIPC' .or. cchan .eq. 'GMEM') THEN
600	#if defined use_comm_SIPC \|\| defined use_comm_GMEM
601	C* Stop if problem in writing in SIPC or GMEM case
602	C
603	IF (istop .NE. 0) CALL HALTE ('STOP in givfld')
604	#endif
605	C
606	ENDIF
607	C
608	C* 3. PIPE Case: flush data files and send message
609	C --------------------------------------------
610	C
611	IF (cchan .EQ. 'PIPE' .or. cchan .eq. 'NONE') THEN
612	C
613	DO 310 jf = 1, kfield
614	C
615	C* Assign local variables
616	C
617	iloc = kindex(jf)
618	clname = cnamout(iloc)
619	iunit = nluout(iloc)
620	clfic = cficout(iloc)
621	clstat = cstate(iloc)
622	C
623	C* Test if field must be exported
624	C
625	IF (clstat .EQ. 'EXPORTED') THEN
626	C
627	C* Close data file
628	C
629	iloc=kindex(jf)
630	isamefic=0
631	DO 3005 jj = 1, jf-1
632	IF (nc_outid(jf) .eq. nc_outid(jj)) THEN
633	isamefic=isamefic+1
634	ENDIF
635	3005 CONTINUE
636	C
637	IF (isamefic .lt. 1) THEN
638	IF (lncdfrst) THEN
639	IF (kiter.eq.nitfn) then
640	CALL hdlerr(NF_CLOSE(nc_outid(jf)), 'givfld')
641	ENDIF
642	ELSE
643	CLOSE(UNIT = iunit, ERR = 3010, IOSTAT = ios)
644	IF (nlogprt .GE. 2) THEN
645	WRITE(UNIT = nulou,FMT = 3100) iunit,clfic
646	ENDIF
647	3010 CONTINUE
648	IF (ios .NE. 0) THEN
649	CALL prtout('Problem in closing unit',
650	$ iunit, 2)
651	CALL prtout('Error message nbr is= ',ios,2)
652	CALL HALTE('STOP in givfld')
653	ENDIF
654	ENDIF
655	ENDIF
656	C
657	C* Send message on pipe clname for PIPE technique
658	C
659	#ifdef use_comm_PIPE
660	CALL PIPE_Send (clname, kiter)
661	#endif
662	ELSE IF (clstat .EQ. 'AUXILARY' .AND. nlogprt .GE. 2) THEN
663	WRITE(UNIT = nulou, FMT = 3300) clname, clfic
664	ENDIF
665	310 CONTINUE
666	ENDIF
667	3100 FORMAT(/,5X,' Unit ',I2,' has been disconnected from file ',A8)
668	3200 FORMAT(/,5X,' Unit ',I2,' has been reconnected to file ',A8)
669	3300 FORMAT(/,5X,' Auxilary field ',A8,' is not written on file ',A8)
670	C
671	C
672	C* 4. End of routine
673	C --------------
674	C
675	IF (nlogprt .GE. 2) THEN
676	WRITE (UNIT = nulou,FMT = *) ' '
677	WRITE (UNIT = nulou,FMT = *)
678	$ ' --------- End of routine givfld ---------'
679	CALL FLUSH (nulou)
680	ENDIF
681	DEALLOCATE (info)
682	DEALLOCATE (iflag)
683	DEALLOCATE (idimlon)
684	DEALLOCATE (idimlat)
685	DEALLOCATE (ivarid)
686	DEALLOCATE (ilongrd)
687	DEALLOCATE (ilatgrd)
688	RETURN
689	END
690

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

Context Navigation

source: CPL/oasis3/trunk/src/mod/oasis3/src/givfld.F @ 1677

Download in other formats: