Context Navigation

create_limit.F @ 115

Last change on this file since 115 was 99, checked in by lmdzadmin, 24 years ago
Version de travail de l'interface avec les surfaces. LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 27.2 KB

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

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

Download in other formats:

Original Format