Context Navigation

limit_netcdf.F @ 320

Last change on this file since 320 was 320, checked in by lmdzadmin, 23 years ago
Adaptation à la version couplée LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 28.6 KB

Line
1	C
2	C $Header$
3	C
4	SUBROUTINE limit_netcdf ( interbar, extrap, oldice, masque )
5	c
6	IMPLICIT none
7	c
8	c-------------------------------------------------------------
9	C Author : L. Fairhead
10	C Date : 27/01/94
11	C Objet : Construction des fichiers de conditions aux limites
12	C pour le nouveau
13	C modele a partir de fichiers de climatologie. Les deux
14	C grilles doivent etre regulieres
15	c
16	c Modifie par z.x.li (le23mars1994)
17	c Modifie par L. Fairhead (fairhead@lmd.jussieu.fr) septembre 1999
18	c pour lecture netcdf dans LMDZ.3.3
19	c Modifie par P;Le Van , juillet 2001
20	c-------------------------------------------------------------
21	c
22	#include "dimensions.h"
23	#include "paramet.h"
24	#include "control.h"
25	#include "logic.h"
26	#include "netcdf.inc"
27	#include "comvert.h"
28	#include "comgeom2.h"
29	#include "comconst.h"
30	#include "dimphy.h"
31	c
32	c-----------------------------------------------------------------------
33	LOGICAL interbar, extrap, oldice
34
35	INTEGER KIDIA, KFDIA, KLON, KLEV
36	c-----------------------------------------------------------------------
37	REAL phy_nat(klon,360), phy_nat0(klon)
38	REAL phy_alb(klon,360)
39	REAL phy_sst(klon,360)
40	REAL phy_bil(klon,360)
41	REAL phy_rug(klon,360)
42	REAL phy_ice(klon,360)
43	c
44	REAL masque(iip1,jjp1)
45	REAL mask(iim,jjp1)
46
47	C Declarations pour le champ de depart
48	INTEGER imdep, jmdep,lmdep
49	INTEGER tbid
50	PARAMETER ( tbid = 60 ) ! >52 semaines
51	REAL timecoord(tbid)
52	c
53	REAL , ALLOCATABLE :: dlon_msk(:), dlat_msk(:)
54	REAL , ALLOCATABLE :: lonmsk_ini(:), latmsk_ini(:)
55	REAL , ALLOCATABLE :: dlon(:), dlat(:)
56	REAL , ALLOCATABLE :: dlon_ini(:), dlat_ini(:)
57	REAL , ALLOCATABLE :: champ_msk(:), champ(:)
58	REAL , ALLOCATABLE :: work(:,:)
59
60	CHARACTER*25 title
61
62	C Declarations pour le champ interpole 2D
63	REAL champint(iim,jjp1)
64	real chmin,chmax
65
66	C Declarations pour le champ interpole 3D
67	REAL champtime(iim,jjp1,tbid)
68	REAL timeyear(tbid)
69	REAL champan(iip1,jjp1,366)
70
71	C Declarations pour l'inteprolation verticale
72	REAL ax(tbid), ay(tbid)
73	REAL by
74	REAL yder(tbid)
75
76
77	INTEGER ierr
78	INTEGER dimfirst(3)
79	INTEGER dimlast(3)
80	c
81	INTEGER nid, ndim, ntim
82	INTEGER dims(2), debut(2), epais(2)
83	INTEGER id_tim
84	INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB
85
86	INTEGER i, j, k, l
87	c Diverses variables locales
88	REAL time
89
90	INTEGER longcles
91	PARAMETER ( longcles = 20 )
92	REAL clesphy0 ( longcles )
93	#include "serre.h"
94	INTEGER ncid,varid,ndimid(4),dimid
95	character*30 namedim
96
97	pi = 4. * ATAN(1.)
98	rad = 6 371 229.
99	omeg = 4.* ASIN(1.)/(24.*3600.)
100	g = 9.8
101	daysec = 86400.
102	kappa = 0.2857143
103	cpp = 1004.70885
104	dtvr = daysec/FLOAT(day_step)
105	c
106	C Traitement du relief au sol
107	c
108	write(,) 'Traitement du relief au sol pour fabriquer masque'
109	ierr = NF_OPEN('Relief.nc', NF_NOWRITE, ncid)
110
111	if (ierr.ne.0) then
112	print *, NF_STRERROR(ierr)
113	STOP
114	ENDIF
115
116	ierr = NF_INQ_VARID(ncid,'RELIEF',varid)
117	if (ierr.ne.0) then
118	print *, NF_STRERROR(ierr)
119	STOP
120	ENDIF
121	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
122	if (ierr.ne.0) then
123	print *, NF_STRERROR(ierr)
124	STOP
125	ENDIF
126	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
127	if (ierr.ne.0) then
128	print *, NF_STRERROR(ierr)
129	STOP
130	ENDIF
131	print*,'variable ', namedim, 'dimension ', imdep
132	ierr = NF_INQ_VARID(ncid,namedim,dimid)
133	if (ierr.ne.0) then
134	print *, NF_STRERROR(ierr)
135	STOP
136	ENDIF
137
138	ALLOCATE( lonmsk_ini(imdep) )
139	ALLOCATE( dlon_msk(imdep) )
140
141	#ifdef NC_DOUBLE
142	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,lonmsk_ini)
143	#else
144	ierr = NF_GET_VAR_REAL(ncid,dimid,lonmsk_ini)
145	#endif
146
147	c
148	if (ierr.ne.0) then
149	print *, NF_STRERROR(ierr)
150	STOP
151	ENDIF
152	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
153	if (ierr.ne.0) then
154	print *, NF_STRERROR(ierr)
155	STOP
156	ENDIF
157	print*,'variable ', namedim, 'dimension ', jmdep
158	ierr = NF_INQ_VARID(ncid,namedim,dimid)
159	if (ierr.ne.0) then
160	print *, NF_STRERROR(ierr)
161	STOP
162	ENDIF
163
164	ALLOCATE( latmsk_ini(jmdep) )
165	ALLOCATE( dlat_msk(jmdep) )
166	ALLOCATE( champ_msk(imdep*jmdep) )
167
168	#ifdef NC_DOUBLE
169	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,latmsk_ini)
170	#else
171	ierr = NF_GET_VAR_REAL(ncid,dimid,latmsk_ini)
172	#endif
173	c
174	if (ierr.ne.0) then
175	print *, NF_STRERROR(ierr)
176	STOP
177	ENDIF
178	#ifdef NC_DOUBLE
179	ierr = NF_GET_VAR_DOUBLE(ncid,varid,champ_msk)
180	#else
181	ierr = NF_GET_VAR_REAL(ncid,varid,champ_msk)
182	#endif
183	c
184	if (ierr.ne.0) then
185	print *, NF_STRERROR(ierr)
186	STOP
187	ENDIF
188	c
189	title='RELIEF'
190
191	CALL conf_dat2d(title,imdep, jmdep, lonmsk_ini, latmsk_ini,
192	. dlon_msk, dlat_msk, champ_msk, interbar )
193
194	CALL mask_c_o(imdep, jmdep, dlon_msk, dlat_msk,champ_msk,
195	. iim, jjp1, rlonv, rlatu, champint)
196	c CALL gr_int_dyn(champint, masque, iim, jjp1)
197	c DO i = 1, iim
198	c masque(i,1) = FLOAT(NINT(masque(i,1)))
199	c masque(i,jjp1) = FLOAT(NINT(masque(i,jjp1)))
200	c ENDDO
201	DO i = 1, iim
202	DO j = 1, jjp1
203	mask(i,j) = champint(i,j)
204	ENDDO
205	ENDDO
206	c CALL gr_dyn_fi(1, iip1, jjp1, klon, masque, phy_nat0)
207	ierr = NF_CLOSE(ncid)
208	c
209	c
210	C Traitement de la rugosite
211	c
212	PRINT*, 'Traitement de la rugosite'
213	ierr = NF_OPEN('Rugos.nc', NF_NOWRITE, ncid)
214	if (ierr.ne.0) then
215	print *, NF_STRERROR(ierr)
216	STOP
217	ENDIF
218
219	ierr = NF_INQ_VARID(ncid,'RUGOS',varid)
220	if (ierr.ne.0) then
221	print *, NF_STRERROR(ierr)
222	STOP
223	ENDIF
224	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
225	if (ierr.ne.0) then
226	print *, NF_STRERROR(ierr)
227	STOP
228	ENDIF
229	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
230	if (ierr.ne.0) then
231	print *, NF_STRERROR(ierr)
232	STOP
233	ENDIF
234	print*,'variable ', namedim, 'dimension ', imdep
235	ierr = NF_INQ_VARID(ncid,namedim,dimid)
236	if (ierr.ne.0) then
237	print *, NF_STRERROR(ierr)
238	STOP
239	ENDIF
240
241	ALLOCATE( dlon_ini(imdep) )
242	ALLOCATE( dlon(imdep) )
243
244	#ifdef NC_DOUBLE
245	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
246	#else
247	ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
248	#endif
249	if (ierr.ne.0) then
250	print *, NF_STRERROR(ierr)
251	STOP
252	ENDIF
253	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
254	if (ierr.ne.0) then
255	print *, NF_STRERROR(ierr)
256	STOP
257	ENDIF
258	print*,'variable ', namedim, 'dimension ', jmdep
259	ierr = NF_INQ_VARID(ncid,namedim,dimid)
260	if (ierr.ne.0) then
261	print *, NF_STRERROR(ierr)
262	STOP
263	ENDIF
264
265	ALLOCATE( dlat_ini(jmdep) )
266	ALLOCATE( dlat(jmdep) )
267
268	#ifdef NC_DOUBLE
269	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
270	#else
271	ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
272	#endif
273	if (ierr.ne.0) then
274	print *, NF_STRERROR(ierr)
275	STOP
276	ENDIF
277	ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
278	if (ierr.ne.0) then
279	print *, NF_STRERROR(ierr)
280	STOP
281	ENDIF
282	print*,'variable ', namedim, 'dimension ', lmdep
283	ierr = NF_INQ_VARID(ncid,namedim,dimid)
284	if (ierr.ne.0) then
285	print *, NF_STRERROR(ierr)
286	STOP
287	ENDIF
288	#ifdef NC_DOUBLE
289	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
290	#else
291	ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
292	#endif
293	if (ierr.ne.0) then
294	print *, NF_STRERROR(ierr)
295	STOP
296	ENDIF
297	c
298	ALLOCATE( champ(imdep*jmdep) )
299
300	DO 200 l = 1, lmdep
301	dimfirst(1) = 1
302	dimfirst(2) = 1
303	dimfirst(3) = l
304	c
305	dimlast(1) = imdep
306	dimlast(2) = jmdep
307	dimlast(3) = 1
308	c
309	PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
310	print*,dimfirst,dimlast
311	#ifdef NC_DOUBLE
312	ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
313	#else
314	ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
315	#endif
316	if (ierr.ne.0) then
317	print *, NF_STRERROR(ierr)
318	STOP
319	ENDIF
320
321	title = 'Rugosite Amip '
322	c
323	CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
324	. dlon, dlat, champ, interbar )
325
326	IF ( interbar ) THEN
327	DO j = 1, imdep * jmdep
328	champ(j) = LOG(champ(j))
329	ENDDO
330
331	IF( l.EQ.1 ) THEN
332	WRITE(6,*) '-------------------------------------------------',
333	,'------------------------'
334	WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
335	, ' pour la rugosite $$$ '
336	WRITE(6,*) '-------------------------------------------------',
337	,'------------------------'
338	ENDIF
339	CALL inter_barxy ( imdep,jmdep -1,dlon,dlat,champ ,
340	, iim,jjm,rlonu,rlatv, jjp1,champint )
341	DO j=1,jjp1
342	DO i=1,iim
343	champint(i,j)=EXP(champint(i,j))
344	ENDDO
345	ENDDO
346
347	DO j = 1, jjp1
348	DO i = 1, iim
349	IF(NINT(mask(i,j)).NE.1) THEN
350	champint( i,j ) = 0.001
351	ENDIF
352	ENDDO
353	ENDDO
354	ELSE
355	CALL rugosite(imdep, jmdep, dlon, dlat, champ,
356	. iim, jjp1, rlonv, rlatu, champint, mask)
357	ENDIF
358	DO j = 1,jjp1
359	DO i = 1, iim
360	champtime (i,j,l) = champint(i,j)
361	ENDDO
362	ENDDO
363	200 CONTINUE
364	c
365	DO l = 1, lmdep
366	timeyear(l) = timecoord(l)
367	ENDDO
368
369	PRINT 222, timeyear
370	222 FORMAT(2x,' Time year ',10f6.1)
371	c
372
373	PRINT*, 'Interpolation temporelle dans l annee'
374
375	DO j = 1, jjp1
376	DO i = 1, iim
377	DO l = 1, lmdep
378	ax(l) = timeyear(l)
379	ay(l) = champtime (i,j,l)
380	ENDDO
381	CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
382	DO k = 1, 360
383	time = FLOAT(k-1)
384	CALL SPLINT(ax,ay,yder,lmdep,time,by)
385	champan(i,j,k) = by
386	ENDDO
387	ENDDO
388	ENDDO
389	DO k = 1, 360
390	DO j = 1, jjp1
391	champan(iip1,j,k) = champan(1,j,k)
392	ENDDO
393	IF ( k.EQ.10 ) THEN
394	DO j = 1, jjp1
395	CALL minmax( iip1,champan(1,j,10),chmin,chmax )
396	PRINT *,' Rugosite au temps 10 ', chmin,chmax,j
397	ENDDO
398	ENDIF
399	ENDDO
400	c
401	DO k = 1, 360
402	CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k), phy_rug(1,k))
403	ENDDO
404	c
405	ierr = NF_CLOSE(ncid)
406
407	DEALLOCATE( dlon )
408	DEALLOCATE( dlon_ini )
409	DEALLOCATE( dlat )
410	DEALLOCATE( dlat_ini )
411	DEALLOCATE( champ )
412	c
413	c
414	C Traitement de la glace oceanique
415	c
416	PRINT*, 'Traitement de la glace oceanique'
417	ierr = NF_OPEN('AMIP.nc', NF_NOWRITE, ncid)
418	if (ierr.ne.0) then
419	print *, NF_STRERROR(ierr)
420	STOP
421	ENDIF
422
423	ierr = NF_INQ_VARID(ncid,'SEA_ICE',varid)
424	if (ierr.ne.0) then
425	print *, NF_STRERROR(ierr)
426	STOP
427	ENDIF
428	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
429	if (ierr.ne.0) then
430	print *, NF_STRERROR(ierr)
431	STOP
432	ENDIF
433	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
434	if (ierr.ne.0) then
435	print *, NF_STRERROR(ierr)
436	STOP
437	ENDIF
438	print*,'variable ', namedim, 'dimension ', imdep
439	ierr = NF_INQ_VARID(ncid,namedim,dimid)
440	if (ierr.ne.0) then
441	print *, NF_STRERROR(ierr)
442	STOP
443	ENDIF
444
445	ALLOCATE ( dlon_ini(imdep) )
446	ALLOCATE ( dlon(imdep) )
447
448	#ifdef NC_DOUBLE
449	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
450	#else
451	ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
452	#endif
453	if (ierr.ne.0) then
454	print *, NF_STRERROR(ierr)
455	STOP
456	ENDIF
457	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
458	if (ierr.ne.0) then
459	print *, NF_STRERROR(ierr)
460	STOP
461	ENDIF
462	print*,'variable ', namedim, jmdep
463	ierr = NF_INQ_VARID(ncid,namedim,dimid)
464	if (ierr.ne.0) then
465	print *, NF_STRERROR(ierr)
466	STOP
467	ENDIF
468
469	ALLOCATE ( dlat_ini(jmdep) )
470	ALLOCATE ( dlat(jmdep) )
471
472	#ifdef NC_DOUBLE
473	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
474	#else
475	ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
476	#endif
477	if (ierr.ne.0) then
478	print *, NF_STRERROR(ierr)
479	STOP
480	ENDIF
481	ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
482	if (ierr.ne.0) then
483	print *, NF_STRERROR(ierr)
484	STOP
485	ENDIF
486	print*,'variable ', namedim, lmdep
487	ierr = NF_INQ_VARID(ncid,namedim,dimid)
488	if (ierr.ne.0) then
489	print *, NF_STRERROR(ierr)
490	STOP
491	ENDIF
492	#ifdef NC_DOUBLE
493	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
494	#else
495	ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
496	#endif
497	if (ierr.ne.0) then
498	print *, NF_STRERROR(ierr)
499	STOP
500	ENDIF
501	c
502	ALLOCATE ( champ(imdep*jmdep) )
503
504	DO l = 1, lmdep
505	dimfirst(1) = 1
506	dimfirst(2) = 1
507	dimfirst(3) = l
508	c
509	dimlast(1) = imdep
510	dimlast(2) = jmdep
511	dimlast(3) = 1
512	c
513	PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
514	#ifdef NC_DOUBLE
515	ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
516	#else
517	ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
518	#endif
519	if (ierr.ne.0) then
520	print *, NF_STRERROR(ierr)
521	STOP
522	ENDIF
523
524	title = 'Sea-ice Amip '
525	c
526	CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
527	. dlon, dlat, champ, interbar )
528	c
529	IF( oldice ) THEN
530	CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
531	. iim, jjp1, rlonv, rlatu, champint )
532	ELSEIF ( interbar ) THEN
533	IF( l.EQ.1 ) THEN
534	WRITE(6,*) '-------------------------------------------------',
535	,'------------------------'
536	WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
537	, ' pour Sea-ice Amip $$$ '
538	WRITE(6,*) '-------------------------------------------------',
539	,'------------------------'
540	ENDIF
541
542	CALL inter_barxy ( imdep,jmdep -1,dlon, dlat ,
543	, champ, iim, jjm, rlonu, rlatv, jjp1, champint )
544	ELSE
545	CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
546	. iim, jjp1, rlonv, rlatu, champint )
547	ENDIF
548	DO j = 1,jjp1
549	DO i = 1, iim
550	champtime (i,j,l) = champint(i,j)
551	ENDDO
552	ENDDO
553	ENDDO
554	c
555	DO l = 1, lmdep
556	timeyear(l) = timecoord(l)
557	ENDDO
558	PRINT 222, timeyear
559	c
560	PRINT*, 'Interpolation temporelle'
561	DO j = 1, jjp1
562	DO i = 1, iim
563	DO l = 1, lmdep
564	ax(l) = timeyear(l)
565	ay(l) = champtime (i,j,l)
566	ENDDO
567	CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
568	DO k = 1, 360
569	time = FLOAT(k-1)
570	CALL SPLINT(ax,ay,yder,lmdep,time,by)
571	champan(i,j,k) = by
572	ENDDO
573	ENDDO
574	ENDDO
575	DO k = 1, 360
576	DO j = 1, jjp1
577	champan(iip1, j, k) = champan(1, j, k)
578	ENDDO
579	IF ( k.EQ.10 ) THEN
580	DO j = 1, jjp1
581	CALL minmax( iip1,champan(1,j,10),chmin,chmax )
582	PRINT *,' Sea ice au temps 10 ', chmin,chmax,j
583	ENDDO
584	ENDIF
585	ENDDO
586	c
587
588	DO k = 1, 360
589	CALL gr_dyn_fi(1, iip1, jjp1, klon,
590	. champan(1,1,k), phy_ice(1,k))
591	DO i = 1, klon
592	phy_nat(i,k) = zmasq(i)
593	IF ( (phy_ice(i,k) - 0.5).GE.1.e-5 ) THEN
594	IF (NINT(zmasq(i)).EQ.0) THEN
595	phy_nat(i,k) = 3.0
596	ELSE
597	phy_nat(i,k) = 2.0
598	ENDIF
599	ENDIF
600	IF( NINT(phy_nat(i,k)).EQ.0 ) THEN
601	IF ( phy_rug(i,k).NE.0.001 ) phy_rug(i,k) = 0.001
602	ENDIF
603	ENDDO
604
605	ENDDO
606	c
607
608	ierr = NF_CLOSE(ncid)
609	c
610	DEALLOCATE( dlon )
611	DEALLOCATE( dlon_ini )
612	DEALLOCATE( dlat )
613	DEALLOCATE( dlat_ini )
614	DEALLOCATE( champ )
615
616	477 continue
617	c
618	C Traitement de la sst
619	c
620	PRINT*, 'Traitement de la sst'
621	ierr = NF_OPEN('AMIP.nc', NF_NOWRITE, ncid)
622	if (ierr.ne.0) then
623	print *, NF_STRERROR(ierr)
624	STOP
625	ENDIF
626
627	ierr = NF_INQ_VARID(ncid,'SST',varid)
628	if (ierr.ne.0) then
629	print *, NF_STRERROR(ierr)
630	STOP
631	ENDIF
632	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
633	if (ierr.ne.0) then
634	print *, NF_STRERROR(ierr)
635	STOP
636	ENDIF
637	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
638	if (ierr.ne.0) then
639	print *, NF_STRERROR(ierr)
640	STOP
641	ENDIF
642	print*,'variable SST ', namedim,'dimension ', imdep
643	ierr = NF_INQ_VARID(ncid,namedim,dimid)
644	if (ierr.ne.0) then
645	print *, NF_STRERROR(ierr)
646	STOP
647	ENDIF
648
649	ALLOCATE( dlon_ini(imdep) )
650	ALLOCATE( dlon(imdep) )
651
652	#ifdef NC_DOUBLE
653	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
654	#else
655	ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
656	#endif
657
658	if (ierr.ne.0) then
659	print *, NF_STRERROR(ierr)
660	STOP
661	ENDIF
662	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
663	if (ierr.ne.0) then
664	print *, NF_STRERROR(ierr)
665	STOP
666	ENDIF
667	print*,'variable SST ', namedim, 'dimension ', jmdep
668	ierr = NF_INQ_VARID(ncid,namedim,dimid)
669	if (ierr.ne.0) then
670	print *, NF_STRERROR(ierr)
671	STOP
672	ENDIF
673
674	ALLOCATE( dlat_ini(jmdep) )
675	ALLOCATE( dlat(jmdep) )
676
677	#ifdef NC_DOUBLE
678	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
679	#else
680	ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
681	#endif
682	if (ierr.ne.0) then
683	print *, NF_STRERROR(ierr)
684	STOP
685	ENDIF
686	ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
687	if (ierr.ne.0) then
688	print *, NF_STRERROR(ierr)
689	STOP
690	ENDIF
691	print*,'variable ', namedim, 'dimension ', lmdep
692	ierr = NF_INQ_VARID(ncid,namedim,dimid)
693	if (ierr.ne.0) then
694	print *, NF_STRERROR(ierr)
695	STOP
696	ENDIF
697	#ifdef NC_DOUBLE
698	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
699	#else
700	ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
701	#endif
702	if (ierr.ne.0) then
703	print *, NF_STRERROR(ierr)
704	STOP
705	ENDIF
706
707	ALLOCATE( champ(imdep*jmdep) )
708	IF( extrap ) THEN
709	ALLOCATE ( work(imdep,jmdep) )
710	ENDIF
711	c
712	DO l = 1, lmdep
713	dimfirst(1) = 1
714	dimfirst(2) = 1
715	dimfirst(3) = l
716	c
717	dimlast(1) = imdep
718	dimlast(2) = jmdep
719	dimlast(3) = 1
720	c
721	PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
722	#ifdef NC_DOUBLE
723	ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
724	#else
725	ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
726	#endif
727	if (ierr.ne.0) then
728	print *, NF_STRERROR(ierr)
729	STOP
730	ENDIF
731
732	title='Sst Amip'
733	c
734	CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
735	. dlon, dlat, champ, interbar )
736	IF ( extrap ) THEN
737	CALL extrapol(champ, imdep, jmdep, 999999.,.TRUE.,.TRUE.,2,work)
738	ENDIF
739	c
740
741	IF ( interbar ) THEN
742	IF( l.EQ.1 ) THEN
743	WRITE(6,*) '-------------------------------------------------',
744	,'------------------------'
745	WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
746	, ' pour la Sst Amip $$$ '
747	WRITE(6,*) '-------------------------------------------------',
748	,'------------------------'
749	ENDIF
750	CALL inter_barxy ( imdep,jmdep -1,dlon, dlat ,
751	, champ, iim, jjm, rlonu, rlatv, jjp1, champint )
752	ELSE
753	CALL grille_m(imdep, jmdep, dlon, dlat, champ,
754	. iim, jjp1, rlonv, rlatu, champint )
755	ENDIF
756
757	DO j = 1,jjp1
758	DO i = 1, iim
759	champtime (i,j,l) = champint(i,j)
760	ENDDO
761	ENDDO
762	ENDDO
763	c
764	DO l = 1, lmdep
765	timeyear(l) = timecoord(l)
766	ENDDO
767	print 222, timeyear
768	c
769	C interpolation temporelle
770	DO j = 1, jjp1
771	DO i = 1, iim
772	DO l = 1, lmdep
773	ax(l) = timeyear(l)
774	ay(l) = champtime (i,j,l)
775	ENDDO
776	CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
777	DO k = 1, 360
778	time = FLOAT(k-1)
779	CALL SPLINT(ax,ay,yder,lmdep,time,by)
780	champan(i,j,k) = by
781	ENDDO
782	ENDDO
783	ENDDO
784	DO k = 1, 360
785	DO j = 1, jjp1
786	champan(iip1,j,k) = champan(1,j,k)
787	ENDDO
788	IF ( k.EQ.10 ) THEN
789	DO j = 1, jjp1
790	CALL minmax( iip1,champan(1,j,10),chmin,chmax )
791	PRINT *,' SST au temps 10 ', chmin,chmax,j
792	ENDDO
793	ENDIF
794	ENDDO
795	c
796	DO k = 1, 360
797	CALL gr_dyn_fi(1, iip1, jjp1, klon,
798	. champan(1,1,k), phy_sst(1,k))
799	ENDDO
800	c
801	ierr = NF_CLOSE(ncid)
802	c
803	DEALLOCATE( dlon )
804	DEALLOCATE( dlon_ini )
805	DEALLOCATE( dlat )
806	DEALLOCATE( dlat_ini )
807	DEALLOCATE( champ )
808	c
809	C Traitement de l'albedo
810	c
811	PRINT*, 'Traitement de l albedo'
812	ierr = NF_OPEN('Albedo.nc', NF_NOWRITE, ncid)
813	if (ierr.ne.0) then
814	print *, NF_STRERROR(ierr)
815	STOP
816	ENDIF
817	ierr = NF_INQ_VARID(ncid,'ALBEDO',varid)
818	if (ierr.ne.0) then
819	print *, NF_STRERROR(ierr)
820	STOP
821	ENDIF
822	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
823	if (ierr.ne.0) then
824	print *, NF_STRERROR(ierr)
825	STOP
826	ENDIF
827	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
828	if (ierr.ne.0) then
829	print *, NF_STRERROR(ierr)
830	STOP
831	ENDIF
832	print*,'variable ', namedim, 'dimension ', imdep
833	ierr = NF_INQ_VARID(ncid,namedim,dimid)
834	if (ierr.ne.0) then
835	print *, NF_STRERROR(ierr)
836	STOP
837	ENDIF
838
839	ALLOCATE ( dlon_ini(imdep) )
840	ALLOCATE ( dlon(imdep) )
841
842	#ifdef NC_DOUBLE
843	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
844	#else
845	ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
846	#endif
847	if (ierr.ne.0) then
848	print *, NF_STRERROR(ierr)
849	STOP
850	ENDIF
851	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
852	if (ierr.ne.0) then
853	print *, NF_STRERROR(ierr)
854	STOP
855	ENDIF
856	print*,'variable ', namedim, 'dimension ', jmdep
857	ierr = NF_INQ_VARID(ncid,namedim,dimid)
858	if (ierr.ne.0) then
859	print *, NF_STRERROR(ierr)
860	STOP
861	ENDIF
862
863	ALLOCATE ( dlat_ini(jmdep) )
864	ALLOCATE ( dlat(jmdep) )
865
866	#ifdef NC_DOUBLE
867	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
868	#else
869	ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
870	#endif
871	if (ierr.ne.0) then
872	print *, NF_STRERROR(ierr)
873	STOP
874	ENDIF
875	ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
876	if (ierr.ne.0) then
877	print *, NF_STRERROR(ierr)
878	STOP
879	ENDIF
880	print*,'variable ', namedim, 'dimension ', lmdep
881	ierr = NF_INQ_VARID(ncid,namedim,dimid)
882	if (ierr.ne.0) then
883	print *, NF_STRERROR(ierr)
884	STOP
885	ENDIF
886	#ifdef NC_DOUBLE
887	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
888	#else
889	ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
890	#endif
891	if (ierr.ne.0) then
892	print *, NF_STRERROR(ierr)
893	STOP
894	ENDIF
895	c
896	ALLOCATE ( champ(imdep*jmdep) )
897
898	DO l = 1, lmdep
899	dimfirst(1) = 1
900	dimfirst(2) = 1
901	dimfirst(3) = l
902	c
903	dimlast(1) = imdep
904	dimlast(2) = jmdep
905	dimlast(3) = 1
906	c
907	PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
908	#ifdef NC_DOUBLE
909	ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
910	#else
911	ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
912	#endif
913	if (ierr.ne.0) then
914	print *, NF_STRERROR(ierr)
915	STOP
916	ENDIF
917
918	title='Albedo Amip'
919	c
920	CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
921	. dlon, dlat, champ, interbar )
922	c
923	c
924	IF ( interbar ) THEN
925	IF( l.EQ.1 ) THEN
926	WRITE(6,*) '-------------------------------------------------',
927	,'------------------------'
928	WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
929	, ' pour l Albedo Amip $$$ '
930	WRITE(6,*) '-------------------------------------------------',
931	,'------------------------'
932	ENDIF
933
934	CALL inter_barxy ( imdep,jmdep -1,dlon, dlat ,
935	, champ, iim, jjm, rlonu, rlatv, jjp1, champint )
936	ELSE
937	CALL grille_m(imdep, jmdep, dlon, dlat, champ,
938	. iim, jjp1, rlonv, rlatu, champint )
939	ENDIF
940	c
941	DO j = 1,jjp1
942	DO i = 1, iim
943	champtime (i, j, l) = champint(i, j)
944	ENDDO
945	ENDDO
946	ENDDO
947	c
948	DO l = 1, lmdep
949	timeyear(l) = timecoord(l)
950	ENDDO
951	print 222, timeyear
952	c
953	C interpolation temporelle
954	DO j = 1, jjp1
955	DO i = 1, iim
956	DO l = 1, lmdep
957	ax(l) = timeyear(l)
958	ay(l) = champtime (i, j, l)
959	ENDDO
960	CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
961	DO k = 1, 360
962	time = FLOAT(k-1)
963	CALL SPLINT(ax,ay,yder,lmdep,time,by)
964	champan(i,j,k) = by
965	ENDDO
966	ENDDO
967	ENDDO
968	DO k = 1, 360
969	DO j = 1, jjp1
970	champan(iip1, j, k) = champan(1, j, k)
971	ENDDO
972	IF ( k.EQ.10 ) THEN
973	DO j = 1, jjp1
974	CALL minmax( iip1,champan(1,j,10),chmin,chmax )
975	PRINT *,' Albedo au temps 10 ', chmin,chmax,j
976	ENDDO
977	ENDIF
978	ENDDO
979	c
980	DO k = 1, 360
981	CALL gr_dyn_fi(1, iip1, jjp1, klon,
982	. champan(1,1,k), phy_alb(1,k))
983	ENDDO
984	c
985	ierr = NF_CLOSE(ncid)
986	c
987	c
988	DO k = 1, 360
989	DO i = 1, klon
990	phy_bil(i,k) = 0.0
991	ENDDO
992	ENDDO
993	c
994	PRINT*, 'Ecriture du fichier limit'
995	c
996	ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid)
997	c
998	ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30,
999	. "Fichier conditions aux limites")
1000	ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim)
1001	ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim)
1002	c
1003	dims(1) = ndim
1004	dims(2) = ntim
1005	c
1006	ccc ierr = NF_DEF_VAR (nid, "TEMPS", NF_DOUBLE, 1,ntim, id_tim)
1007	ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim)
1008	ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17,
1009	. "Jour dans l annee")
1010	ccc ierr = NF_DEF_VAR (nid, "NAT", NF_DOUBLE, 2,dims, id_NAT)
1011	ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT)
1012	ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23,
1013	. "Nature du sol (0,1,2,3)")
1014	ccc ierr = NF_DEF_VAR (nid, "SST", NF_DOUBLE, 2,dims, id_SST)
1015	ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST)
1016	ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35,
1017	. "Temperature superficielle de la mer")
1018	ccc ierr = NF_DEF_VAR (nid, "BILS", NF_DOUBLE, 2,dims, id_BILS)
1019	ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS)
1020	ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32,
1021	. "Reference flux de chaleur au sol")
1022	ccc ierr = NF_DEF_VAR (nid, "ALB", NF_DOUBLE, 2,dims, id_ALB)
1023	ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB)
1024	ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19,
1025	. "Albedo a la surface")
1026	ccc ierr = NF_DEF_VAR (nid, "RUG", NF_DOUBLE, 2,dims, id_RUG)
1027	ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG)
1028	ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8,
1029	. "Rugosite")
1030	c
1031	ierr = NF_ENDDEF(nid)
1032	c
1033	DO k = 1, 360
1034	c
1035	debut(1) = 1
1036	debut(2) = k
1037	epais(1) = klon
1038	epais(2) = 1
1039	c
1040	#ifdef NC_DOUBLE
1041	ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k))
1042	ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais,phy_nat(1,k))
1043	ierr = NF_PUT_VARA_DOUBLE (nid,id_SST,debut,epais,phy_sst(1,k))
1044	ierr = NF_PUT_VARA_DOUBLE (nid,id_BILS,debut,epais,phy_bil(1,k))
1045	ierr = NF_PUT_VARA_DOUBLE (nid,id_ALB,debut,epais,phy_alb(1,k))
1046	ierr = NF_PUT_VARA_DOUBLE (nid,id_RUG,debut,epais,phy_rug(1,k))
1047	#else
1048	ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k))
1049	ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais,phy_nat(1,k))
1050	ierr = NF_PUT_VARA_REAL (nid,id_SST,debut,epais,phy_sst(1,k))
1051	ierr = NF_PUT_VARA_REAL (nid,id_BILS,debut,epais,phy_bil(1,k))
1052	ierr = NF_PUT_VARA_REAL (nid,id_ALB,debut,epais,phy_alb(1,k))
1053	ierr = NF_PUT_VARA_REAL (nid,id_RUG,debut,epais,phy_rug(1,k))
1054	#endif
1055	c
1056	ENDDO
1057	c
1058	ierr = NF_CLOSE(nid)
1059	c
1060	STOP
1061	END

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

Download in other formats:

Original Format