Context Navigation

limit_netcdf.F @ 1293

Last change on this file since 1293 was 1293, checked in by lguez, 14 years ago

1) Replaced calls to "float" by calls to "real" and "dble" in
"phys_cosp". "call construct_cosp_gridbox(float(itap),..." was a bug
since the corresponding dummy argument has the type "double
precision". (And "float" is not in the Fortran standard.)

2) Modifications for the program "create_etat0_limit" only, "gcm" is
not touched:

2.1) Removed generic interface "startget" in module "startvar". Replaced
calls to "startget" by calls to "startget_phys2d", "startget_dyn" and
"startget_phys1d".

2.2) Simplified the interface of "startget_dyn" and made it more secure by
removing arguments for sizes of arrays and using assumed-shape array
arguments.

2.3) Corrected bug in call to "startget_dyn" for northward velocity. See
ticket #25 in Trac.

2.4) Collected procedures "inter_barxy", "inter_barx", "inter_bary",
"ord_coord" and "ord_coordm" in a module. "inter_barxy" is the only
public procedure in the module. Rewrote those five procedures: removed
arguments for sizes of arrays; used assumed-shape array arguments;
used array expressions; translated some spaghetti code in "inter_bary"
into structured code; corrected bug in "inter_bary", described by
ticket #26 in Trac.

2.5) Corrected a bug in "inter_bary": "y0" was initialized at 0
instead of -90. This bug made values at the south pole wrong. (This bug
has been acknowledeged by P. Le Van.)

2.6) Made the variable "champ" in procedure "limit_netcdf" an array of
rank 2. Thus it can be an argument in the call to the newly-secured
"inter_barxy".

2.7) The files "start.nc", "startphy.nc" and "limit.nc" are impacted
by this revision. There is a significant change in the variable "vcov"
of "start.nc". See
http://web.lmd.jussieu.fr/~lglmd/Rev_1293/index.html. Note also the
changed value of "vcov" at the south pole. There is very little change
in other variables, in all three files.

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 37.5 KB

Line
1	!
2	! $Id: limit_netcdf.F 1293 2009-12-22 11:07:26Z lguez $
3	!
4	C
5	C
6	SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque)
7	#ifdef CPP_EARTH
8	! This routine is designed to work for Earth
9	USE dimphy
10	use phys_state_var_mod , ONLY : pctsrf
11	use inter_barxy_m, only: inter_barxy
12
13	IMPLICIT none
14	c
15	c-------------------------------------------------------------
16	C Author : L. Fairhead
17	C Date : 27/01/94
18	C Objet : Construction des fichiers de conditions aux limites
19	C pour le nouveau
20	C modele a partir de fichiers de climatologie. Les deux
21	C grilles doivent etre regulieres
22	c
23	c Modifie par z.x.li (le23mars1994)
24	c Modifie par L. Fairhead (fairhead@lmd.jussieu.fr) septembre 1999
25	c pour lecture netcdf dans LMDZ.3.3
26	c Modifie par P;Le Van , juillet 2001
27	c-------------------------------------------------------------
28	c
29	#include "dimensions.h"
30	#include "paramet.h"
31	#include "control.h"
32	#include "logic.h"
33	#include "netcdf.inc"
34	#include "comvert.h"
35	#include "comgeom2.h"
36	#include "comconst.h"
37	cy#include "dimphy.h"
38	#include "indicesol.h"
39	#include "iniprint.h"
40	c
41	c-----------------------------------------------------------------------
42	LOGICAL interbar, extrap, oldice
43
44	REAL phy_nat(klon,360), phy_nat0(klon)
45	REAL phy_alb(klon,360)
46	REAL phy_sst(klon,360)
47	REAL phy_bil(klon,360)
48	REAL phy_rug(klon,360)
49	REAL phy_ice(klon)
50	c
51	real pctsrf_t(klon,nbsrf,360)
52
53	REAL verif
54
55	REAL masque(iip1,jjp1)
56	REAL mask(iim,jjp1)
57	CPB
58	C newlmt indique l'utilisation de la sous-maille fractionnelle
59	C tandis que l'ancien codage utilise l'indicateur du sol (0,1,2,3)
60	LOGICAL newlmt, fracterre
61	PARAMETER(newlmt=.TRUE.)
62	PARAMETER(fracterre = .TRUE.)
63
64	C Declarations pour le champ de depart
65	INTEGER imdep, jmdep,lmdep
66	INTEGER tbid
67	PARAMETER ( tbid = 60 ) ! >52 semaines
68	REAL timecoord(tbid)
69	c
70	REAL , ALLOCATABLE :: dlon_msk(:), dlat_msk(:)
71	REAL , ALLOCATABLE :: lonmsk_ini(:), latmsk_ini(:)
72	REAL , ALLOCATABLE :: dlon(:), dlat(:)
73	REAL , ALLOCATABLE :: dlon_ini(:), dlat_ini(:)
74	REAL , ALLOCATABLE :: champ_msk(:), champ(:, :)
75	REAL , ALLOCATABLE :: work(:,:)
76
77	CHARACTER*25 title
78
79	C Declarations pour le champ interpole 2D
80	REAL champint(iim,jjp1)
81	real chmin,chmax
82
83	C Declarations pour le champ interpole 3D
84	REAL champtime(iim,jjp1,tbid)
85	REAL timeyear(tbid)
86	REAL champan(iip1,jjp1,366)
87
88	C Declarations pour l'inteprolation verticale
89	REAL ax(tbid), ay(tbid)
90	REAL by
91	REAL yder(tbid)
92
93
94	INTEGER ierr
95	INTEGER dimfirst(3)
96	INTEGER dimlast(3)
97	c
98	INTEGER nid, ndim, ntim
99	INTEGER dims(2), debut(2), epais(2)
100	INTEGER id_tim
101	INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB
102	CPB
103	INTEGER id_FOCE, id_FSIC, id_FTER, id_FLIC
104
105	INTEGER i, j, k, l, ji
106	c declarations pour lecture glace de mer
107	INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret
108	INTEGER :: itaul(1), fid
109	REAL :: lev(1), date, dt
110	REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic
111	REAL, ALLOCATABLE, DIMENSION(:) :: dlon_lic, dlat_lic
112	REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic
113	REAL :: flic_tmp(iip1, jjp1)
114
115	c Diverses variables locales
116	REAL time
117	! pour la lecture du fichier masque ocean
118	integer :: nid_o2a
119	logical :: couple = .false.
120	INTEGER :: iml_omask, jml_omask
121	REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask
122	REAL, ALLOCATABLE, DIMENSION(:) :: dlon_omask, dlat_omask
123	REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp
124	real, dimension(klon) :: ocemask_fi
125
126	INTEGER longcles
127	PARAMETER ( longcles = 20 )
128	REAL clesphy0 ( longcles )
129	#include "serre.h"
130	INTEGER ncid,varid,ndimid(4),dimid
131	character*30 namedim
132	CHARACTER*80 :: varname
133
134	cIM28/02/2002 <== PM
135	REAL tmidmonth(12)
136	SAVE tmidmonth
137	DATA tmidmonth/15,45,75,105,135,165,195,225,255,285,315,345/
138
139	c initialisations:
140	CALL conf_gcm( 99, .TRUE. , clesphy0 )
141
142
143	pi = 4. * ATAN(1.)
144	rad = 6 371 229.
145	omeg = 4.* ASIN(1.)/(24.*3600.)
146	g = 9.8
147	daysec = 86400.
148	kappa = 0.2857143
149	cpp = 1004.70885
150	dtvr = daysec/FLOAT(day_step)
151	CALL inigeom
152	c
153	C Traitement du relief au sol
154	c
155	write(,) 'Traitement du relief au sol pour fabriquer masque'
156	ierr = NF_OPEN('Relief.nc', NF_NOWRITE, ncid)
157
158	if (ierr.ne.0) then
159	print *, NF_STRERROR(ierr)
160	STOP
161	ENDIF
162
163	ierr = NF_INQ_VARID(ncid,'RELIEF',varid)
164	if (ierr.ne.0) then
165	print *, NF_STRERROR(ierr)
166	STOP
167	ENDIF
168	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
169	if (ierr.ne.0) then
170	print *, NF_STRERROR(ierr)
171	STOP
172	ENDIF
173	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
174	if (ierr.ne.0) then
175	print *, NF_STRERROR(ierr)
176	STOP
177	ENDIF
178	print*,'variable ', namedim, 'dimension ', imdep
179	ierr = NF_INQ_VARID(ncid,namedim,dimid)
180	if (ierr.ne.0) then
181	print *, NF_STRERROR(ierr)
182	STOP
183	ENDIF
184
185	ALLOCATE( lonmsk_ini(imdep) )
186	ALLOCATE( dlon_msk(imdep) )
187
188	#ifdef NC_DOUBLE
189	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,lonmsk_ini)
190	#else
191	ierr = NF_GET_VAR_REAL(ncid,dimid,lonmsk_ini)
192	#endif
193
194	c
195	if (ierr.ne.0) then
196	print *, NF_STRERROR(ierr)
197	STOP
198	ENDIF
199	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
200	if (ierr.ne.0) then
201	print *, NF_STRERROR(ierr)
202	STOP
203	ENDIF
204	print*,'variable ', namedim, 'dimension ', jmdep
205	ierr = NF_INQ_VARID(ncid,namedim,dimid)
206	if (ierr.ne.0) then
207	print *, NF_STRERROR(ierr)
208	STOP
209	ENDIF
210
211	ALLOCATE( latmsk_ini(jmdep) )
212	ALLOCATE( dlat_msk(jmdep) )
213	ALLOCATE( champ_msk(imdep*jmdep) )
214
215	#ifdef NC_DOUBLE
216	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,latmsk_ini)
217	#else
218	ierr = NF_GET_VAR_REAL(ncid,dimid,latmsk_ini)
219	#endif
220	c
221	if (ierr.ne.0) then
222	print *, NF_STRERROR(ierr)
223	STOP
224	ENDIF
225	#ifdef NC_DOUBLE
226	ierr = NF_GET_VAR_DOUBLE(ncid,varid,champ_msk)
227	#else
228	ierr = NF_GET_VAR_REAL(ncid,varid,champ_msk)
229	#endif
230	c
231	if (ierr.ne.0) then
232	print *, NF_STRERROR(ierr)
233	STOP
234	ENDIF
235	c
236	title='RELIEF'
237
238	CALL conf_dat2d(title,imdep, jmdep, lonmsk_ini, latmsk_ini,
239	. dlon_msk, dlat_msk, champ_msk, interbar )
240
241	DO i = 1, iim
242	DO j = 1, jjp1
243	mask(i,j) = masque(i,j)
244	ENDDO
245	ENDDO
246	WRITE(,) 'MASK:'
247	WRITE(*,'(96i1)')INT(mask)
248	ierr = NF_CLOSE(ncid)
249	c
250	c
251	C Traitement de la rugosite
252	c
253	PRINT*, 'Traitement de la rugosite'
254	ierr = NF_OPEN('Rugos.nc', NF_NOWRITE, ncid)
255	if (ierr.ne.0) then
256	print *, NF_STRERROR(ierr)
257	STOP
258	ENDIF
259
260	ierr = NF_INQ_VARID(ncid,'RUGOS',varid)
261	if (ierr.ne.0) then
262	print *, NF_STRERROR(ierr)
263	STOP
264	ENDIF
265	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
266	if (ierr.ne.0) then
267	print *, NF_STRERROR(ierr)
268	STOP
269	ENDIF
270	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
271	if (ierr.ne.0) then
272	print *, NF_STRERROR(ierr)
273	STOP
274	ENDIF
275	print*,'variable ', namedim, 'dimension ', imdep
276	ierr = NF_INQ_VARID(ncid,namedim,dimid)
277	if (ierr.ne.0) then
278	print *, NF_STRERROR(ierr)
279	STOP
280	ENDIF
281
282	ALLOCATE( dlon_ini(imdep) )
283	ALLOCATE( dlon(imdep) )
284
285	#ifdef NC_DOUBLE
286	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
287	#else
288	ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
289	#endif
290	if (ierr.ne.0) then
291	print *, NF_STRERROR(ierr)
292	STOP
293	ENDIF
294	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
295	if (ierr.ne.0) then
296	print *, NF_STRERROR(ierr)
297	STOP
298	ENDIF
299	print*,'variable ', namedim, 'dimension ', jmdep
300	ierr = NF_INQ_VARID(ncid,namedim,dimid)
301	if (ierr.ne.0) then
302	print *, NF_STRERROR(ierr)
303	STOP
304	ENDIF
305
306	ALLOCATE( dlat_ini(jmdep) )
307	ALLOCATE( dlat(jmdep) )
308
309	#ifdef NC_DOUBLE
310	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
311	#else
312	ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
313	#endif
314	if (ierr.ne.0) then
315	print *, NF_STRERROR(ierr)
316	STOP
317	ENDIF
318	ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
319	if (ierr.ne.0) then
320	print *, NF_STRERROR(ierr)
321	STOP
322	ENDIF
323	print*,'variable ', namedim, 'dimension ', lmdep
324	ierr = NF_INQ_VARID(ncid,namedim,dimid)
325	if (ierr.ne.0) then
326	print *, NF_STRERROR(ierr)
327	STOP
328	ENDIF
329	#ifdef NC_DOUBLE
330	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
331	#else
332	ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
333	#endif
334	if (ierr.ne.0) then
335	print *, NF_STRERROR(ierr)
336	STOP
337	ENDIF
338	c
339	ALLOCATE( champ(imdep, jmdep) )
340
341	DO 200 l = 1, lmdep
342	dimfirst(1) = 1
343	dimfirst(2) = 1
344	dimfirst(3) = l
345	c
346	dimlast(1) = imdep
347	dimlast(2) = jmdep
348	dimlast(3) = 1
349	c
350	PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
351	print*,dimfirst,dimlast
352	#ifdef NC_DOUBLE
353	ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
354	#else
355	ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
356	#endif
357	if (ierr.ne.0) then
358	print *, NF_STRERROR(ierr)
359	STOP
360	ENDIF
361
362	title = 'Rugosite Amip '
363	c
364	CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
365	. dlon, dlat, champ, interbar )
366
367	IF ( interbar ) THEN
368	IF( l.EQ.1 ) THEN
369	WRITE(6,*) '-------------------------------------------------',
370	,'------------------------'
371	WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
372	, ' pour la rugosite $$$ '
373	WRITE(6,*) '-------------------------------------------------',
374	,'------------------------'
375	ENDIF
376	CALL inter_barxy(dlon, dlat(:jmdep -1), log(champ), rlonu(:iim),
377	$ rlatv, champint)
378	DO j=1,jjp1
379	DO i=1,iim
380	champint(i,j)=EXP(champint(i,j))
381	ENDDO
382	ENDDO
383
384	DO j = 1, jjp1
385	DO i = 1, iim
386	IF(NINT(mask(i,j)).NE.1) THEN
387	champint( i,j ) = 0.001
388	ENDIF
389	ENDDO
390	ENDDO
391	ELSE
392	CALL rugosite(imdep, jmdep, dlon, dlat, champ,
393	. iim, jjp1, rlonv, rlatu, champint, mask)
394	ENDIF
395	DO j = 1,jjp1
396	DO i = 1, iim
397	champtime (i,j,l) = champint(i,j)
398	ENDDO
399	ENDDO
400	200 CONTINUE
401	c
402	DO l = 1, lmdep
403	timeyear(l) = timecoord(l)
404	ENDDO
405
406	PRINT 222, timeyear(:lmdep)
407	222 FORMAT(2x,' Time year ',10f6.1)
408	c
409
410	PRINT*, 'Interpolation temporelle dans l annee'
411
412	DO j = 1, jjp1
413	DO i = 1, iim
414	DO l = 1, lmdep
415	ax(l) = timeyear(l)
416	ay(l) = champtime (i,j,l)
417	ENDDO
418	CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
419	DO k = 1, 360
420	time = FLOAT(k-1)
421	CALL SPLINT(ax,ay,yder,lmdep,time,by)
422	champan(i,j,k) = by
423	ENDDO
424	ENDDO
425	ENDDO
426	DO k = 1, 360
427	DO j = 1, jjp1
428	champan(iip1,j,k) = champan(1,j,k)
429	ENDDO
430	IF ( k.EQ.10 ) THEN
431	DO j = 1, jjp1
432	CALL minmax( iip1,champan(1,j,10),chmin,chmax )
433	PRINT *,' Rugosite au temps 10 ', chmin,chmax,j
434	ENDDO
435	ENDIF
436	ENDDO
437	c
438	DO k = 1, 360
439	CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k), phy_rug(1,k))
440	ENDDO
441	c
442	ierr = NF_CLOSE(ncid)
443
444	DEALLOCATE( dlon )
445	DEALLOCATE( dlon_ini )
446	DEALLOCATE( dlat )
447	DEALLOCATE( dlat_ini )
448	DEALLOCATE( champ )
449	c
450	c
451	C Traitement de la glace oceanique
452	c
453	PRINT*, 'Traitement de la glace oceanique'
454
455	ierr = NF_OPEN('amipbc_sic_1x1.nc', NF_NOWRITE, ncid)
456	if (ierr.ne.0) THEN
457	ierr = NF_OPEN('amipbc_sic_1x1_clim.nc', NF_NOWRITE, ncid)
458	if (ierr.ne.0) THEN
459	print *, NF_STRERROR(ierr)
460	STOP
461	endif
462	ENDIF
463
464	cIM22/02/2002
465	cIM07/03/2002 AMIP.nc & amip79to95.nc
466	cIM ierr = NF_INQ_VARID(ncid,'SEA_ICE',varid)
467	cIM07/03/2002 amipbc_sic_1x1_clim.nc & amipbc_sic_1x1.nc
468	ierr = NF_INQ_VARID(ncid,'sicbcs',varid)
469	cIM22/02/2002
470	if (ierr.ne.0) then
471	print *, NF_STRERROR(ierr),'sicbcs'
472	STOP
473	ENDIF
474	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
475	if (ierr.ne.0) then
476	print *, NF_STRERROR(ierr)
477	STOP
478	ENDIF
479	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
480	if (ierr.ne.0) then
481	print *, NF_STRERROR(ierr)
482	STOP
483	ENDIF
484	print*,'variable ', namedim, 'dimension ', imdep
485	ierr = NF_INQ_VARID(ncid,namedim,dimid)
486	if (ierr.ne.0) then
487	print *, NF_STRERROR(ierr)
488	STOP
489	ENDIF
490
491	ALLOCATE ( dlon_ini(imdep) )
492	ALLOCATE ( dlon(imdep) )
493
494	#ifdef NC_DOUBLE
495	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
496	#else
497	ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
498	#endif
499	if (ierr.ne.0) then
500	print *, NF_STRERROR(ierr)
501	STOP
502	ENDIF
503	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
504	if (ierr.ne.0) then
505	print *, NF_STRERROR(ierr)
506	STOP
507	ENDIF
508	print*,'variable ', namedim, jmdep
509	ierr = NF_INQ_VARID(ncid,namedim,dimid)
510	if (ierr.ne.0) then
511	print *, NF_STRERROR(ierr)
512	STOP
513	ENDIF
514
515	ALLOCATE ( dlat_ini(jmdep) )
516	ALLOCATE ( dlat(jmdep) )
517
518	#ifdef NC_DOUBLE
519	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
520	#else
521	ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
522	#endif
523	if (ierr.ne.0) then
524	print *, NF_STRERROR(ierr)
525	STOP
526	ENDIF
527	ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
528	if (ierr.ne.0) then
529	print *, NF_STRERROR(ierr)
530	STOP
531	ENDIF
532	print*,'variable ', namedim, lmdep
533	cIM28/02/2002
534	cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours
535	c Ici on suppose qu'on a 12 mois (de 30 jours).
536	IF (lmdep.NE.12) THEN
537	print *, 'Unknown AMIP file: not 12 months ?'
538	STOP
539	ENDIF
540	cIM28/02/2002
541	ierr = NF_INQ_VARID(ncid,namedim,dimid)
542	if (ierr.ne.0) then
543	print *, NF_STRERROR(ierr)
544	STOP
545	ENDIF
546	#ifdef NC_DOUBLE
547	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
548	#else
549	ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
550	#endif
551	if (ierr.ne.0) then
552	print *, NF_STRERROR(ierr)
553	STOP
554	ENDIF
555	c
556	ALLOCATE ( champ(imdep, jmdep) )
557
558	DO l = 1, lmdep
559	dimfirst(1) = 1
560	dimfirst(2) = 1
561	dimfirst(3) = l
562	c
563	dimlast(1) = imdep
564	dimlast(2) = jmdep
565	dimlast(3) = 1
566	c
567	PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
568	#ifdef NC_DOUBLE
569	ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
570	#else
571	ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
572	#endif
573	if (ierr.ne.0) then
574	print *, NF_STRERROR(ierr)
575	STOP
576	ENDIF
577
578	title = 'Sea-ice Amip '
579	c
580	CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
581	. dlon, dlat, champ, interbar )
582	c
583	IF( oldice ) THEN
584	CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
585	. iim, jjp1, rlonv, rlatu, champint )
586	ELSEIF ( interbar ) THEN
587	IF( l.EQ.1 ) THEN
588	WRITE(6,*) '-------------------------------------------------',
589	,'------------------------'
590	WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
591	, ' pour Sea-ice Amip $$$ '
592	WRITE(6,*) '-------------------------------------------------',
593	,'------------------------'
594	ENDIF
595	cIM07/03/2002
596	cIM22/02/2002 : Sea-ice Amip entre 0. et 1.
597	cIM PRINT*,'SUB. limit_netcdf.F IM : Sea-ice et SST Amip_new clim'
598	cIM DO j = 1, imdep * jmdep
599	cIM28/02/2002 <==PM champ(j) = champ(j)/100.
600	cIM14/03/2002 champ(j) = max(0.0,(min(1.0, (champ(j)/100.) )))
601	cIM champ(j) = amax1(0.0,(amin1(1.0, (champ(j)/100.) )))
602	cIM ENDDO
603	cIM22/02/2002
604	CALL inter_barxy (dlon, dlat(:jmdep -1), champ, rlonu(:iim),
605	$ rlatv, champint)
606	ELSE
607	CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
608	. iim, jjp1, rlonv, rlatu, champint )
609	ENDIF
610	DO j = 1,jjp1
611	DO i = 1, iim
612	champtime (i,j,l) = champint(i,j)
613	ENDDO
614	ENDDO
615	ENDDO
616	c
617	DO l = 1, lmdep
618	cIM28/02/2002 <== PM timeyear(l) = timecoord(l)
619	cIM timeyear(l) = timecoord(l)
620	cIM07/03/2002
621	timeyear(l) = tmidmonth(l)
622	ENDDO
623	PRINT 222, timeyear(:lmdep)
624	c
625	PRINT*, 'Interpolation temporelle'
626	DO j = 1, jjp1
627	DO i = 1, iim
628	DO l = 1, lmdep
629	ax(l) = timeyear(l)
630	ay(l) = champtime (i,j,l)
631	ENDDO
632	CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
633	DO k = 1, 360
634	time = FLOAT(k-1)
635	CALL SPLINT(ax,ay,yder,lmdep,time,by)
636	champan(i,j,k) = by
637	ENDDO
638	ENDDO
639	ENDDO
640	DO k = 1, 360
641	DO j = 1, jjp1
642	champan(iip1, j, k) = champan(1, j, k)
643	ENDDO
644	IF ( k.EQ.10 ) THEN
645	DO j = 1, jjp1
646	CALL minmax( iip1,champan(1,j,10),chmin,chmax )
647	PRINT *,' Sea ice au temps 10 ', chmin,chmax,j
648	ENDDO
649	ENDIF
650	ENDDO
651	c
652	cIM14/03/2002 : Sea-ice Amip entre 0. et 1.
653	PRINT*,'SUB. limit_netcdf.F IM : Sea-ice Amipbc '
654	DO k = 1, 360
655	DO j = 1, jjp1
656	DO i = 1, iim
657	champan(i, j, k) =
658	$ amax1(0.0,(amin1(1.0,(champan(i, j, k)/100.))))
659	ENDDO
660	champan(iip1, j, k) = champan(1, j, k)
661	ENDDO
662	ENDDO
663	cIM14/03/2002
664
665	DO k = 1, 360
666	CALL gr_dyn_fi(1, iip1, jjp1, klon,
667	. champan(1,1,k), phy_ice)
668	IF ( newlmt) THEN
669
670	CPB en attendant de mettre fraction de terre
671	c
672	WHERE(phy_ice(1:klon) .GE. 1.) phy_ice(1 : klon) = 1.
673	WHERE(phy_ice(1:klon) .LT. EPSFRA) phy_ice(1 : klon) = 0.
674	c
675	IF (fracterre ) THEN
676	c WRITE(,) 'passe dans cas fracterre'
677	pctsrf_t(:,is_ter,k) = pctsrf(:,is_ter)
678	pctsrf_t(:,is_lic,k) = pctsrf(:,is_lic)
679	pctsrf_t(1:klon,is_sic,k) = phy_ice(1:klon)
680	$ - pctsrf_t(1:klon,is_lic,k)
681	c Il y a des cas ou il y a de la glace dans landiceref et pas dans AMIP
682	WHERE (pctsrf_t(1:klon,is_sic,k) .LE. 0)
683	pctsrf_t(1:klon,is_sic,k) = 0.
684	END WHERE
685	WHERE( 1. - zmasq(1:klon) .LT. EPSFRA)
686	pctsrf_t(1:klon,is_sic,k) = 0.
687	pctsrf_t(1:klon,is_oce,k) = 0.
688	END WHERE
689	DO i = 1, klon
690	IF ( 1. - zmasq(i) .GT. EPSFRA) THEN
691	IF ( pctsrf_t(i,is_sic,k) .GE. 1 - zmasq(i)) THEN
692	pctsrf_t(i,is_sic,k) = 1 - zmasq(i)
693	pctsrf_t(i,is_oce,k) = 0.
694	ELSE
695	pctsrf_t(i,is_oce,k) = 1 - zmasq(i)
696	$ - pctsrf_t(i,is_sic,k)
697	IF (pctsrf_t(i,is_oce,k) .LT. EPSFRA) THEN
698	pctsrf_t(i,is_oce,k) = 0.
699	pctsrf_t(i,is_sic,k) = 1 - zmasq(i)
700	ENDIF
701	ENDIF
702	ENDIF
703	if (pctsrf_t(i,is_oce,k) .lt. 0.) then
704	WRITE(,) 'pb sous maille au point : i,k '
705	$ , i,k,pctsrf_t(:,is_oce,k)
706	ENDIF
707	IF ( abs( pctsrf_t(i, is_ter,k) + pctsrf_t(i, is_lic,k) +
708	$ pctsrf_t(i, is_oce,k) + pctsrf_t(i, is_sic,k) - 1.)
709	$ .GT. EPSFRA) THEN
710	WRITE(,) 'physiq : pb sous surface au point ', i,
711	$ pctsrf_t(i, 1 : nbsrf,k), phy_ice(i)
712	ENDIF
713	END DO
714	ELSE
715	DO i = 1, klon
716	pctsrf_t(i,is_ter,k) = pctsrf(i,is_ter)
717	IF (NINT(pctsrf(i,is_ter)).EQ.1 ) THEN
718	pctsrf_t(i,is_sic,k) = 0.
719	pctsrf_t(i,is_oce,k) = 0.
720	IF(phy_ice(i) .GE. 1.e-5) THEN
721	pctsrf_t(i,is_lic,k) = phy_ice(i)
722	pctsrf_t(i,is_ter,k) = pctsrf_t(i,is_ter,k)
723	. - pctsrf_t(i,is_lic,k)
724	ELSE
725	pctsrf_t(i,is_lic,k) = 0.
726	ENDIF
727	ELSE
728	pctsrf_t(i,is_lic,k) = 0.
729	IF(phy_ice(i) .GE. 1.e-5) THEN
730	pctsrf_t(i,is_ter,k) = 0.
731	pctsrf_t(i,is_sic,k) = phy_ice(i)
732	pctsrf_t(i,is_oce,k) = 1. - pctsrf_t(i,is_sic,k)
733	ELSE
734	pctsrf_t(i,is_sic,k) = 0.
735	pctsrf_t(i,is_oce,k) = 1.
736	ENDIF
737	ENDIF
738	verif = pctsrf_t(i,is_ter,k) +
739	. pctsrf_t(i,is_oce,k) +
740	. pctsrf_t(i,is_sic,k) +
741	. pctsrf_t(i,is_lic,k)
742	IF ( verif .LT. 1. - 1.e-5 .OR.
743	$ verif .GT. 1 + 1.e-5) THEN
744	WRITE(,) 'pb sous maille au point : i,k,verif '
745	$ , i,k,verif
746	ENDIF
747	END DO
748	ENDIF
749	ELSE
750	DO i = 1, klon
751	phy_nat(i,k) = phy_nat0(i)
752	IF ( (phy_ice(i) - 0.5).GE.1.e-5 ) THEN
753	IF (NINT(phy_nat0(i)).EQ.0) THEN
754	phy_nat(i,k) = 3.0
755	ELSE
756	phy_nat(i,k) = 2.0
757	ENDIF
758	ENDIF
759	IF( NINT(phy_nat(i,k)).EQ.0 ) THEN
760	IF ( phy_rug(i,k).NE.0.001 ) phy_rug(i,k) = 0.001
761	ENDIF
762	END DO
763	ENDIF
764	ENDDO
765	c
766
767	ierr = NF_CLOSE(ncid)
768	c
769	DEALLOCATE( dlon )
770	DEALLOCATE( dlon_ini )
771	DEALLOCATE( dlat )
772	DEALLOCATE( dlat_ini )
773	DEALLOCATE( champ )
774
775	477 continue
776	c
777	C Traitement de la sst
778	c
779	PRINT*, 'Traitement de la sst'
780	c ierr = NF_OPEN('AMIP_SST.nc', NF_NOWRITE, ncid)
781	ierr = NF_OPEN('amipbc_sst_1x1.nc', NF_NOWRITE, ncid)
782	if (ierr.ne.0) THEN
783	ierr = NF_OPEN('amipbc_sst_1x1_clim.nc', NF_NOWRITE, ncid)
784	if (ierr.ne.0) THEN
785	print *, NF_STRERROR(ierr)
786	STOP
787	endif
788	ENDIF
789
790	cIM22/02/2002
791	cIM ierr = NF_INQ_VARID(ncid,'SST',varid)
792	ierr = NF_INQ_VARID(ncid,'tosbcs',varid)
793	cIM22/02/2002
794	if (ierr.ne.0) then
795	print *, NF_STRERROR(ierr)
796	STOP
797	ENDIF
798	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
799	if (ierr.ne.0) then
800	print *, NF_STRERROR(ierr)
801	STOP
802	ENDIF
803	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
804	if (ierr.ne.0) then
805	print *, NF_STRERROR(ierr)
806	STOP
807	ENDIF
808	print*,'variable SST ', namedim,'dimension ', imdep
809	ierr = NF_INQ_VARID(ncid,namedim,dimid)
810	if (ierr.ne.0) then
811	print *, NF_STRERROR(ierr)
812	STOP
813	ENDIF
814
815	ALLOCATE( dlon_ini(imdep) )
816	ALLOCATE( dlon(imdep) )
817
818	#ifdef NC_DOUBLE
819	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
820	#else
821	ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
822	#endif
823
824	if (ierr.ne.0) then
825	print *, NF_STRERROR(ierr)
826	STOP
827	ENDIF
828	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
829	if (ierr.ne.0) then
830	print *, NF_STRERROR(ierr)
831	STOP
832	ENDIF
833	print*,'variable SST ', namedim, 'dimension ', jmdep
834	ierr = NF_INQ_VARID(ncid,namedim,dimid)
835	if (ierr.ne.0) then
836	print *, NF_STRERROR(ierr)
837	STOP
838	ENDIF
839
840	ALLOCATE( dlat_ini(jmdep) )
841	ALLOCATE( dlat(jmdep) )
842
843	#ifdef NC_DOUBLE
844	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
845	#else
846	ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
847	#endif
848	if (ierr.ne.0) then
849	print *, NF_STRERROR(ierr)
850	STOP
851	ENDIF
852	ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
853	if (ierr.ne.0) then
854	print *, NF_STRERROR(ierr)
855	STOP
856	ENDIF
857	print*,'variable ', namedim, 'dimension ', lmdep
858	cIM28/02/2002
859	cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours
860	c Ici on suppose qu'on a 12 mois (de 30 jours).
861	IF (lmdep.NE.12) THEN
862	print *, 'Unknown AMIP file: not 12 months ?'
863	STOP
864	ENDIF
865	cIM28/02/2002
866	ierr = NF_INQ_VARID(ncid,namedim,dimid)
867	if (ierr.ne.0) then
868	print *, NF_STRERROR(ierr)
869	STOP
870	ENDIF
871	#ifdef NC_DOUBLE
872	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
873	#else
874	ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
875	#endif
876	if (ierr.ne.0) then
877	print *, NF_STRERROR(ierr)
878	STOP
879	ENDIF
880
881	ALLOCATE( champ(imdep, jmdep) )
882	IF( extrap ) THEN
883	ALLOCATE ( work(imdep,jmdep) )
884	ENDIF
885	c
886	DO l = 1, lmdep
887	dimfirst(1) = 1
888	dimfirst(2) = 1
889	dimfirst(3) = l
890	c
891	dimlast(1) = imdep
892	dimlast(2) = jmdep
893	dimlast(3) = 1
894	c
895	PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
896	#ifdef NC_DOUBLE
897	ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
898	#else
899	ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
900	#endif
901	if (ierr.ne.0) then
902	print *, NF_STRERROR(ierr)
903	STOP
904	ENDIF
905
906	title='Sst Amip'
907	c
908	CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
909	. dlon, dlat, champ, interbar )
910	IF ( extrap ) THEN
911	CALL extrapol(champ, imdep, jmdep, 999999.,.TRUE.,.TRUE.,2,work)
912	ENDIF
913	c
914
915	IF ( interbar ) THEN
916	IF( l.EQ.1 ) THEN
917	WRITE(6,*) '-------------------------------------------------',
918	,'------------------------'
919	WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
920	, ' pour la Sst Amip $$$ '
921	WRITE(6,*) '-------------------------------------------------',
922	,'------------------------'
923	ENDIF
924	CALL inter_barxy (dlon, dlat(:jmdep -1), champ, rlonu(:iim),
925	$ rlatv, champint)
926	ELSE
927	CALL grille_m(imdep, jmdep, dlon, dlat, champ,
928	. iim, jjp1, rlonv, rlatu, champint )
929	ENDIF
930
931	DO j = 1,jjp1
932	DO i = 1, iim
933	champtime (i,j,l) = champint(i,j)
934	ENDDO
935	ENDDO
936	ENDDO
937	c
938	DO l = 1, lmdep
939	cIM28/02/2002 <==PM timeyear(l) = timecoord(l)
940	timeyear(l) = tmidmonth(l)
941	ENDDO
942	print 222, timeyear(:lmdep)
943	c
944	C interpolation temporelle
945	DO j = 1, jjp1
946	DO i = 1, iim
947	DO l = 1, lmdep
948	ax(l) = timeyear(l)
949	ay(l) = champtime (i,j,l)
950	ENDDO
951	CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
952	DO k = 1, 360
953	time = FLOAT(k-1)
954	CALL SPLINT(ax,ay,yder,lmdep,time,by)
955	champan(i,j,k) = by
956	ENDDO
957	ENDDO
958	ENDDO
959	DO k = 1, 360
960	DO j = 1, jjp1
961	champan(iip1,j,k) = champan(1,j,k)
962	ENDDO
963	IF ( k.EQ.10 ) THEN
964	DO j = 1, jjp1
965	CALL minmax( iip1,champan(1,j,10),chmin,chmax )
966	PRINT *,' SST au temps 10 ', chmin,chmax,j
967	ENDDO
968	ENDIF
969	ENDDO
970	c
971	cIM14/03/2002 : SST amipbc greater then 271.38
972	PRINT*,'SUB. limit_netcdf.F IM : SST Amipbc >= 271.38 '
973	DO k = 1, 360
974	DO j = 1, jjp1
975	DO i = 1, iim
976	champan(i, j, k) = amax1(champan(i, j, k), 271.38)
977	ENDDO
978	champan(iip1, j, k) = champan(1, j, k)
979	ENDDO
980	ENDDO
981	cIM14/03/2002
982	DO k = 1, 360
983	CALL gr_dyn_fi(1, iip1, jjp1, klon,
984	. champan(1,1,k), phy_sst(1,k))
985	ENDDO
986	c
987	ierr = NF_CLOSE(ncid)
988	c
989	DEALLOCATE( dlon )
990	DEALLOCATE( dlon_ini )
991	DEALLOCATE( dlat )
992	DEALLOCATE( dlat_ini )
993	DEALLOCATE( champ )
994	c
995	C Traitement de l'albedo
996	c
997	PRINT*, 'Traitement de l albedo'
998	ierr = NF_OPEN('Albedo.nc', NF_NOWRITE, ncid)
999	if (ierr.ne.0) then
1000	print *, NF_STRERROR(ierr)
1001	STOP
1002	ENDIF
1003	ierr = NF_INQ_VARID(ncid,'ALBEDO',varid)
1004	if (ierr.ne.0) then
1005	print *, NF_STRERROR(ierr)
1006	STOP
1007	ENDIF
1008	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
1009	if (ierr.ne.0) then
1010	print *, NF_STRERROR(ierr)
1011	STOP
1012	ENDIF
1013	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
1014	if (ierr.ne.0) then
1015	print *, NF_STRERROR(ierr)
1016	STOP
1017	ENDIF
1018	print*,'variable ', namedim, 'dimension ', imdep
1019	ierr = NF_INQ_VARID(ncid,namedim,dimid)
1020	if (ierr.ne.0) then
1021	print *, NF_STRERROR(ierr)
1022	STOP
1023	ENDIF
1024
1025	ALLOCATE ( dlon_ini(imdep) )
1026	ALLOCATE ( dlon(imdep) )
1027
1028	#ifdef NC_DOUBLE
1029	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
1030	#else
1031	ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
1032	#endif
1033	if (ierr.ne.0) then
1034	print *, NF_STRERROR(ierr)
1035	STOP
1036	ENDIF
1037	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
1038	if (ierr.ne.0) then
1039	print *, NF_STRERROR(ierr)
1040	STOP
1041	ENDIF
1042	print*,'variable ', namedim, 'dimension ', jmdep
1043	ierr = NF_INQ_VARID(ncid,namedim,dimid)
1044	if (ierr.ne.0) then
1045	print *, NF_STRERROR(ierr)
1046	STOP
1047	ENDIF
1048
1049	ALLOCATE ( dlat_ini(jmdep) )
1050	ALLOCATE ( dlat(jmdep) )
1051
1052	#ifdef NC_DOUBLE
1053	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
1054	#else
1055	ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
1056	#endif
1057	if (ierr.ne.0) then
1058	print *, NF_STRERROR(ierr)
1059	STOP
1060	ENDIF
1061	ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
1062	if (ierr.ne.0) then
1063	print *, NF_STRERROR(ierr)
1064	STOP
1065	ENDIF
1066	print*,'variable ', namedim, 'dimension ', lmdep
1067	ierr = NF_INQ_VARID(ncid,namedim,dimid)
1068	if (ierr.ne.0) then
1069	print *, NF_STRERROR(ierr)
1070	STOP
1071	ENDIF
1072	#ifdef NC_DOUBLE
1073	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
1074	#else
1075	ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
1076	#endif
1077	if (ierr.ne.0) then
1078	print *, NF_STRERROR(ierr)
1079	STOP
1080	ENDIF
1081	c
1082	ALLOCATE ( champ(imdep, jmdep) )
1083
1084	DO l = 1, lmdep
1085	dimfirst(1) = 1
1086	dimfirst(2) = 1
1087	dimfirst(3) = l
1088	c
1089	dimlast(1) = imdep
1090	dimlast(2) = jmdep
1091	dimlast(3) = 1
1092	c
1093	PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
1094	#ifdef NC_DOUBLE
1095	ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
1096	#else
1097	ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
1098	#endif
1099	if (ierr.ne.0) then
1100	print *, NF_STRERROR(ierr)
1101	STOP
1102	ENDIF
1103
1104	title='Albedo Amip'
1105	c
1106	CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
1107	. dlon, dlat, champ, interbar )
1108	c
1109	c
1110	IF ( interbar ) THEN
1111	IF( l.EQ.1 ) THEN
1112	WRITE(6,*) '-------------------------------------------------',
1113	,'------------------------'
1114	WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
1115	, ' pour l Albedo Amip $$$ '
1116	WRITE(6,*) '-------------------------------------------------',
1117	,'------------------------'
1118	ENDIF
1119
1120	CALL inter_barxy(dlon, dlat(:jmdep-1), champ, rlonu(:iim),
1121	$ rlatv, champint)
1122	ELSE
1123	CALL grille_m(imdep, jmdep, dlon, dlat, champ,
1124	. iim, jjp1, rlonv, rlatu, champint )
1125	ENDIF
1126	c
1127	DO j = 1,jjp1
1128	DO i = 1, iim
1129	champtime (i, j, l) = champint(i, j)
1130	ENDDO
1131	ENDDO
1132	ENDDO
1133	c
1134	DO l = 1, lmdep
1135	timeyear(l) = timecoord(l)
1136	ENDDO
1137	print 222, timeyear(:lmdep)
1138	c
1139	C interpolation temporelle
1140	DO j = 1, jjp1
1141	DO i = 1, iim
1142	DO l = 1, lmdep
1143	ax(l) = timeyear(l)
1144	ay(l) = champtime (i, j, l)
1145	ENDDO
1146	CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
1147	DO k = 1, 360
1148	time = FLOAT(k-1)
1149	CALL SPLINT(ax,ay,yder,lmdep,time,by)
1150	champan(i,j,k) = by
1151	ENDDO
1152	ENDDO
1153	ENDDO
1154	DO k = 1, 360
1155	DO j = 1, jjp1
1156	champan(iip1, j, k) = champan(1, j, k)
1157	ENDDO
1158	IF ( k.EQ.10 ) THEN
1159	DO j = 1, jjp1
1160	CALL minmax( iip1,champan(1,j,10),chmin,chmax )
1161	PRINT *,' Albedo au temps 10 ', chmin,chmax,j
1162	ENDDO
1163	ENDIF
1164	ENDDO
1165	c
1166	DO k = 1, 360
1167	CALL gr_dyn_fi(1, iip1, jjp1, klon,
1168	. champan(1,1,k), phy_alb(1,k))
1169	ENDDO
1170	c
1171	ierr = NF_CLOSE(ncid)
1172	c
1173	c
1174	DO k = 1, 360
1175	DO i = 1, klon
1176	phy_bil(i,k) = 0.0
1177	ENDDO
1178	ENDDO
1179	c
1180	PRINT*, 'Ecriture du fichier limit'
1181	c
1182	ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid)
1183	c
1184	ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30,
1185	. "Fichier conditions aux limites")
1186	ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim)
1187	ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim)
1188	c
1189	dims(1) = ndim
1190	dims(2) = ntim
1191	c
1192	#ifdef NC_DOUBLE
1193	ierr = NF_DEF_VAR (nid, "TEMPS", NF_DOUBLE, 1,ntim, id_tim)
1194	#else
1195	ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim)
1196	#endif
1197	ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17,
1198	. "Jour dans l annee")
1199	IF (newlmt) THEN
1200	c
1201	#ifdef NC_DOUBLE
1202	ierr = NF_DEF_VAR (nid, "FOCE", NF_DOUBLE, 2,dims, id_FOCE)
1203	#else
1204	ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 2,dims, id_FOCE)
1205	#endif
1206	ierr = NF_PUT_ATT_TEXT (nid, id_FOCE, "title", 14,
1207	. "Fraction ocean")
1208	c
1209	#ifdef NC_DOUBLE
1210	ierr = NF_DEF_VAR (nid, "FSIC", NF_DOUBLE, 2,dims, id_FSIC)
1211	#else
1212	ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 2,dims, id_FSIC)
1213	#endif
1214	ierr = NF_PUT_ATT_TEXT (nid, id_FSIC, "title", 21,
1215	. "Fraction glace de mer")
1216	c
1217	#ifdef NC_DOUBLE
1218	ierr = NF_DEF_VAR (nid, "FTER", NF_DOUBLE, 2,dims, id_FTER)
1219	#else
1220	ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 2,dims, id_FTER)
1221	#endif
1222	ierr = NF_PUT_ATT_TEXT (nid, id_FTER, "title", 14,
1223	. "Fraction terre")
1224	c
1225	#ifdef NC_DOUBLE
1226	ierr = NF_DEF_VAR (nid, "FLIC", NF_DOUBLE, 2,dims, id_FLIC)
1227	#else
1228	ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 2,dims, id_FLIC)
1229	#endif
1230	ierr = NF_PUT_ATT_TEXT (nid, id_FLIC, "title", 17,
1231	. "Fraction land ice")
1232	c
1233	ELSE
1234	#ifdef NC_DOUBLE
1235	ierr = NF_DEF_VAR (nid, "NAT", NF_DOUBLE, 2,dims, id_NAT)
1236	#else
1237	ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT)
1238	#endif
1239	ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23,
1240	. "Nature du sol (0,1,2,3)")
1241	ENDIF
1242	#ifdef NC_DOUBLE
1243	ierr = NF_DEF_VAR (nid, "SST", NF_DOUBLE, 2,dims, id_SST)
1244	#else
1245	ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST)
1246	#endif
1247	ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35,
1248	. "Temperature superficielle de la mer")
1249	#ifdef NC_DOUBLE
1250	ierr = NF_DEF_VAR (nid, "BILS", NF_DOUBLE, 2,dims, id_BILS)
1251	#else
1252	ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS)
1253	#endif
1254	ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32,
1255	. "Reference flux de chaleur au sol")
1256	#ifdef NC_DOUBLE
1257	ierr = NF_DEF_VAR (nid, "ALB", NF_DOUBLE, 2,dims, id_ALB)
1258	#else
1259	ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB)
1260	#endif
1261	ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19,
1262	. "Albedo a la surface")
1263	#ifdef NC_DOUBLE
1264	ierr = NF_DEF_VAR (nid, "RUG", NF_DOUBLE, 2,dims, id_RUG)
1265	#else
1266	ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG)
1267	#endif
1268	ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8,
1269	. "Rugosite")
1270	c
1271	ierr = NF_ENDDEF(nid)
1272	c
1273	DO k = 1, 360
1274	c
1275	debut(1) = 1
1276	debut(2) = k
1277	epais(1) = klon
1278	epais(2) = 1
1279	c
1280	#ifdef NC_DOUBLE
1281	ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k))
1282	c
1283	IF (newlmt ) THEN
1284	ierr = NF_PUT_VARA_DOUBLE (nid,id_FOCE,debut,epais
1285	$ ,pctsrf_t(1,is_oce,k))
1286	ierr = NF_PUT_VARA_DOUBLE (nid,id_FSIC,debut,epais
1287	$ ,pctsrf_t(1,is_sic,k))
1288	ierr = NF_PUT_VARA_DOUBLE (nid,id_FTER,debut,epais
1289	$ ,pctsrf_t(1,is_ter,k))
1290	ierr = NF_PUT_VARA_DOUBLE (nid,id_FLIC,debut,epais
1291	$ ,pctsrf_t(1,is_lic,k))
1292	ELSE
1293	ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais
1294	$ ,phy_nat(1,k))
1295	ENDIF
1296	c
1297	ierr = NF_PUT_VARA_DOUBLE (nid,id_SST,debut,epais,phy_sst(1,k))
1298	ierr = NF_PUT_VARA_DOUBLE (nid,id_BILS,debut,epais,phy_bil(1,k))
1299	ierr = NF_PUT_VARA_DOUBLE (nid,id_ALB,debut,epais,phy_alb(1,k))
1300	ierr = NF_PUT_VARA_DOUBLE (nid,id_RUG,debut,epais,phy_rug(1,k))
1301	#else
1302	ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k))
1303	IF (newlmt ) THEN
1304	ierr = NF_PUT_VARA_REAL (nid,id_FOCE,debut,epais
1305	$ ,pctsrf_t(1,is_oce,k))
1306	ierr = NF_PUT_VARA_REAL (nid,id_FSIC,debut,epais
1307	$ ,pctsrf_t(1,is_sic,k))
1308	ierr = NF_PUT_VARA_REAL (nid,id_FTER,debut,epais
1309	$ ,pctsrf_t(1,is_ter,k))
1310	ierr = NF_PUT_VARA_REAL (nid,id_FLIC,debut,epais
1311	$ ,pctsrf_t(1,is_lic,k))
1312	ELSE
1313	ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais
1314	$ ,phy_nat(1,k))
1315	ENDIF
1316	ierr = NF_PUT_VARA_REAL (nid,id_SST,debut,epais,phy_sst(1,k))
1317	ierr = NF_PUT_VARA_REAL (nid,id_BILS,debut,epais,phy_bil(1,k))
1318	ierr = NF_PUT_VARA_REAL (nid,id_ALB,debut,epais,phy_alb(1,k))
1319	ierr = NF_PUT_VARA_REAL (nid,id_RUG,debut,epais,phy_rug(1,k))
1320	#endif
1321	c
1322	ENDDO
1323	c
1324	ierr = NF_CLOSE(nid)
1325	c
1326	#else
1327	WRITE(lunout,*)
1328	& 'limit_netcdf: Earth-specific routine, needs Earth physics'
1329	#endif
1330	! of #ifdef CPP_EARTH
1331	STOP
1332	END

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

Download in other formats:

Original Format