Context Navigation

mod_1D_cases_read.F90 @ 2310

Last change on this file since 2310 was 2310, checked in by Laurent Fairhead, 9 years ago
Modifications for 1d model MPL
Property svn:keywords set to `Id`
File size: 34.0 KB

Line
1	!
2	! $Id: mod_1D_cases_read.F90 2310 2015-06-24 10:04:31Z fairhead $
3	!
4	MODULE mod_1D_cases_read
5
6	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7	!Declarations specifiques au cas standard
8	character*80 :: fich_cas
9	! Discrétisation
10	integer nlev_cas, nt_cas
11
12
13	integer year_ini_cas, day_ini_cas, mth_ini_cas
14	real heure_ini_cas
15	real day_ju_ini_cas ! Julian day of case first day
16	! parameter (year_ini_cas=2011)
17	parameter (year_ini_cas=1969)
18	! parameter (mth_ini_cas=10)
19	parameter (mth_ini_cas=6)
20	! parameter (day_ini_cas=1) ! 10 = 10Juil2006
21	parameter (day_ini_cas=24) ! 24 = 24 juin 1969
22	parameter (heure_ini_cas=0.) !0h en secondes
23	real pdt_cas
24	parameter (pdt_cas=3.*3600)
25
26	!CR ATTENTION TEST AMMA
27	! parameter (year_ini_cas=2006)
28	! parameter (mth_ini_cas=7)
29	! parameter (day_ini_cas=10) ! 10 = 10Juil2006
30	! parameter (heure_ini_cas=0.) !0h en secondes
31	! parameter (pdt_cas=1800.)
32
33	!profils environnementaux
34	real, allocatable:: plev_cas(:,:)
35
36	real, allocatable:: z_cas(:,:)
37	real, allocatable:: t_cas(:,:),q_cas(:,:),rh_cas(:,:)
38	real, allocatable:: th_cas(:,:),rv_cas(:,:)
39	real, allocatable:: u_cas(:,:)
40	real, allocatable:: v_cas(:,:)
41
42	!forcing
43	real, allocatable:: ht_cas(:,:),vt_cas(:,:),dt_cas(:,:),dtrad_cas(:,:)
44	real, allocatable:: hth_cas(:,:),vth_cas(:,:),dth_cas(:,:)
45	real, allocatable:: hq_cas(:,:),vq_cas(:,:),dq_cas(:,:)
46	real, allocatable:: hr_cas(:,:),vr_cas(:,:),dr_cas(:,:)
47	real, allocatable:: hu_cas(:,:),vu_cas(:,:),du_cas(:,:)
48	real, allocatable:: hv_cas(:,:),vv_cas(:,:),dv_cas(:,:)
49	real, allocatable:: vitw_cas(:,:)
50	real, allocatable:: ug_cas(:,:),vg_cas(:,:)
51	real, allocatable:: lat_cas(:),sens_cas(:),ts_cas(:),ustar_cas(:)
52
53	!champs interpoles
54	real, allocatable:: plev_prof_cas(:)
55	real, allocatable:: t_prof_cas(:)
56	real, allocatable:: q_prof_cas(:)
57	real, allocatable:: u_prof_cas(:)
58	real, allocatable:: v_prof_cas(:)
59
60	real, allocatable:: vitw_prof_cas(:)
61	real, allocatable:: ug_prof_cas(:)
62	real, allocatable:: vg_prof_cas(:)
63	real, allocatable:: ht_prof_cas(:)
64	real, allocatable:: hq_prof_cas(:)
65	real, allocatable:: vt_prof_cas(:)
66	real, allocatable:: vq_prof_cas(:)
67	real, allocatable:: dt_prof_cas(:)
68	real, allocatable:: dtrad_prof_cas(:)
69	real, allocatable:: dq_prof_cas(:)
70	real, allocatable:: hu_prof_cas(:)
71	real, allocatable:: hv_prof_cas(:)
72	real, allocatable:: vu_prof_cas(:)
73	real, allocatable:: vv_prof_cas(:)
74	real, allocatable:: du_prof_cas(:)
75	real, allocatable:: dv_prof_cas(:)
76
77
78	real lat_prof_cas,sens_prof_cas,ts_prof_cas,ustar_prof_cas
79
80
81
82	CONTAINS
83
84	SUBROUTINE read_1D_cas
85	implicit none
86
87	#include "netcdf.inc"
88
89	INTEGER nid,rid,ierr
90	INTEGER ii,jj
91
92	fich_cas='setup/cas.nc'
93	print*,'fich_cas ',fich_cas
94	ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid)
95	print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid
96	if (ierr.NE.NF_NOERR) then
97	write(,) 'ERROR: GROS Pb opening forcings nc file '
98	write(,) NF_STRERROR(ierr)
99	stop ""
100	endif
101	!.......................................................................
102	ierr=NF_INQ_DIMID(nid,'lat',rid)
103	IF (ierr.NE.NF_NOERR) THEN
104	print*, 'Oh probleme lecture dimension lat'
105	ENDIF
106	ierr=NF_INQ_DIMLEN(nid,rid,ii)
107	print*,'OK nid,rid,lat',nid,rid,ii
108	!.......................................................................
109	ierr=NF_INQ_DIMID(nid,'lon',rid)
110	IF (ierr.NE.NF_NOERR) THEN
111	print*, 'Oh probleme lecture dimension lon'
112	ENDIF
113	ierr=NF_INQ_DIMLEN(nid,rid,jj)
114	print*,'OK nid,rid,lat',nid,rid,jj
115	!.......................................................................
116	ierr=NF_INQ_DIMID(nid,'lev',rid)
117	IF (ierr.NE.NF_NOERR) THEN
118	print*, 'Oh probleme lecture dimension zz'
119	ENDIF
120	ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas)
121	print*,'OK nid,rid,nlev_cas',nid,rid,nlev_cas
122	!.......................................................................
123	ierr=NF_INQ_DIMID(nid,'time',rid)
124	print*,'nid,rid',nid,rid
125	nt_cas=0
126	IF (ierr.NE.NF_NOERR) THEN
127	stop 'probleme lecture dimension sens'
128	ENDIF
129	ierr=NF_INQ_DIMLEN(nid,rid,nt_cas)
130	print*,'nid,rid,nlev_cas',nid,rid,nt_cas
131
132	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
133	!profils moyens:
134	allocate(plev_cas(nlev_cas,nt_cas))
135	allocate(z_cas(nlev_cas,nt_cas))
136	allocate(t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas),rh_cas(nlev_cas,nt_cas))
137	allocate(th_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas))
138	allocate(u_cas(nlev_cas,nt_cas))
139	allocate(v_cas(nlev_cas,nt_cas))
140
141	!forcing
142	allocate(ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas),dt_cas(nlev_cas,nt_cas),dtrad_cas(nlev_cas,nt_cas))
143	allocate(hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas),dq_cas(nlev_cas,nt_cas))
144	allocate(hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas),dth_cas(nlev_cas,nt_cas))
145	allocate(hr_cas(nlev_cas,nt_cas),vr_cas(nlev_cas,nt_cas),dr_cas(nlev_cas,nt_cas))
146	allocate(hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas),du_cas(nlev_cas,nt_cas))
147	allocate(hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas),dv_cas(nlev_cas,nt_cas))
148	allocate(vitw_cas(nlev_cas,nt_cas))
149	allocate(ug_cas(nlev_cas,nt_cas))
150	allocate(vg_cas(nlev_cas,nt_cas))
151	allocate(lat_cas(nt_cas),sens_cas(nt_cas),ts_cas(nt_cas),ustar_cas(nt_cas))
152
153
154	!champs interpoles
155	allocate(plev_prof_cas(nlev_cas))
156	allocate(t_prof_cas(nlev_cas))
157	allocate(q_prof_cas(nlev_cas))
158	allocate(u_prof_cas(nlev_cas))
159	allocate(v_prof_cas(nlev_cas))
160
161	allocate(vitw_prof_cas(nlev_cas))
162	allocate(ug_prof_cas(nlev_cas))
163	allocate(vg_prof_cas(nlev_cas))
164	allocate(ht_prof_cas(nlev_cas))
165	allocate(hq_prof_cas(nlev_cas))
166	allocate(hu_prof_cas(nlev_cas))
167	allocate(hv_prof_cas(nlev_cas))
168	allocate(vt_prof_cas(nlev_cas))
169	allocate(vq_prof_cas(nlev_cas))
170	allocate(vu_prof_cas(nlev_cas))
171	allocate(vv_prof_cas(nlev_cas))
172	allocate(dt_prof_cas(nlev_cas))
173	allocate(dtrad_prof_cas(nlev_cas))
174	allocate(dq_prof_cas(nlev_cas))
175	allocate(du_prof_cas(nlev_cas))
176	allocate(dv_prof_cas(nlev_cas))
177
178	print*,'Allocations OK'
179	call read_cas(nid,nlev_cas,nt_cas &
180	& ,z_cas,plev_cas,t_cas,q_cas,rh_cas,th_cas,rv_cas,u_cas,v_cas &
181	& ,ug_cas,vg_cas,vitw_cas,du_cas,hu_cas,vu_cas,dv_cas,hv_cas,vv_cas &
182	& ,dt_cas,dtrad_cas,ht_cas,vt_cas,dq_cas,hq_cas,vq_cas &
183	& ,dth_cas,hth_cas,vth_cas,dr_cas,hr_cas,vr_cas,sens_cas,lat_cas,ts_cas,ustar_cas)
184
185
186	END SUBROUTINE read_1D_cas
187
188
189
190	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
191	SUBROUTINE deallocate_1D_cases
192	!profils environnementaux:
193	deallocate(plev_cas)
194
195	deallocate(z_cas)
196	deallocate(t_cas,q_cas,rh_cas)
197	deallocate(th_cas,rv_cas)
198	deallocate(u_cas)
199	deallocate(v_cas)
200
201	!forcing
202	deallocate(ht_cas,vt_cas,dt_cas,dtrad_cas)
203	deallocate(hq_cas,vq_cas,dq_cas)
204	deallocate(hth_cas,vth_cas,dth_cas)
205	deallocate(hr_cas,vr_cas,dr_cas)
206	deallocate(hu_cas,vu_cas,du_cas)
207	deallocate(hv_cas,vv_cas,dv_cas)
208	deallocate(vitw_cas)
209	deallocate(ug_cas)
210	deallocate(vg_cas)
211	deallocate(lat_cas,sens_cas,ts_cas,ustar_cas)
212
213	!champs interpoles
214	deallocate(plev_prof_cas)
215	deallocate(t_prof_cas)
216	deallocate(q_prof_cas)
217	deallocate(u_prof_cas)
218	deallocate(v_prof_cas)
219
220	deallocate(vitw_prof_cas)
221	deallocate(ug_prof_cas)
222	deallocate(vg_prof_cas)
223	deallocate(ht_prof_cas)
224	deallocate(hq_prof_cas)
225	deallocate(hu_prof_cas)
226	deallocate(hv_prof_cas)
227	deallocate(vt_prof_cas)
228	deallocate(vq_prof_cas)
229	deallocate(vu_prof_cas)
230	deallocate(vv_prof_cas)
231	deallocate(dt_prof_cas)
232	deallocate(dtrad_prof_cas)
233	deallocate(dq_prof_cas)
234	deallocate(du_prof_cas)
235	deallocate(dv_prof_cas)
236	deallocate(t_prof_cas)
237	deallocate(q_prof_cas)
238	deallocate(u_prof_cas)
239	deallocate(v_prof_cas)
240
241	END SUBROUTINE deallocate_1D_cases
242
243
244	END MODULE mod_1D_cases_read
245	!=====================================================================
246	subroutine read_cas(nid,nlevel,ntime &
247	& ,zz,pp,temp,qv,rh,theta,rv,u,v,ug,vg,w, &
248	& du,hu,vu,dv,hv,vv,dt,dtrad,ht,vt,dq,hq,vq, &
249	& dth,hth,vth,dr,hr,vr,sens,flat,ts,ustar)
250
251	!program reading forcing of the case study
252	implicit none
253	#include "netcdf.inc"
254
255	integer ntime,nlevel
256
257	real zz(nlevel,ntime)
258	real pp(nlevel,ntime)
259	real temp(nlevel,ntime),qv(nlevel,ntime),rh(nlevel,ntime)
260	real theta(nlevel,ntime),rv(nlevel,ntime)
261	real u(nlevel,ntime)
262	real v(nlevel,ntime)
263	real ug(nlevel,ntime)
264	real vg(nlevel,ntime)
265	real w(nlevel,ntime)
266	real du(nlevel,ntime),hu(nlevel,ntime),vu(nlevel,ntime)
267	real dv(nlevel,ntime),hv(nlevel,ntime),vv(nlevel,ntime)
268	real dt(nlevel,ntime),ht(nlevel,ntime),vt(nlevel,ntime)
269	real dtrad(nlevel,ntime)
270	real dq(nlevel,ntime),hq(nlevel,ntime),vq(nlevel,ntime)
271	real dth(nlevel,ntime),hth(nlevel,ntime),vth(nlevel,ntime)
272	real dr(nlevel,ntime),hr(nlevel,ntime),vr(nlevel,ntime)
273	real flat(ntime),sens(ntime),ts(ntime),ustar(ntime)
274
275
276	integer nid, ierr,rid
277	integer nbvar3d
278	parameter(nbvar3d=39)
279	integer var3didin(nbvar3d)
280
281	ierr=NF_INQ_VARID(nid,"zz",var3didin(1))
282	if(ierr/=NF_NOERR) then
283	write(,) NF_STRERROR(ierr)
284	stop 'lev'
285	endif
286
287	ierr=NF_INQ_VARID(nid,"pp",var3didin(2))
288	if(ierr/=NF_NOERR) then
289	write(,) NF_STRERROR(ierr)
290	stop 'plev'
291	endif
292
293
294	ierr=NF_INQ_VARID(nid,"temp",var3didin(3))
295	if(ierr/=NF_NOERR) then
296	write(,) NF_STRERROR(ierr)
297	stop 'temp'
298	endif
299
300	ierr=NF_INQ_VARID(nid,"qv",var3didin(4))
301	if(ierr/=NF_NOERR) then
302	write(,) NF_STRERROR(ierr)
303	stop 'qv'
304	endif
305
306	ierr=NF_INQ_VARID(nid,"rh",var3didin(5))
307	if(ierr/=NF_NOERR) then
308	write(,) NF_STRERROR(ierr)
309	stop 'rh'
310	endif
311
312	ierr=NF_INQ_VARID(nid,"theta",var3didin(6))
313	if(ierr/=NF_NOERR) then
314	write(,) NF_STRERROR(ierr)
315	stop 'theta'
316	endif
317
318	ierr=NF_INQ_VARID(nid,"rv",var3didin(7))
319	if(ierr/=NF_NOERR) then
320	write(,) NF_STRERROR(ierr)
321	stop 'rv'
322	endif
323
324
325	ierr=NF_INQ_VARID(nid,"u",var3didin(8))
326	if(ierr/=NF_NOERR) then
327	write(,) NF_STRERROR(ierr)
328	stop 'u'
329	endif
330
331	ierr=NF_INQ_VARID(nid,"v",var3didin(9))
332	if(ierr/=NF_NOERR) then
333	write(,) NF_STRERROR(ierr)
334	stop 'v'
335	endif
336
337	ierr=NF_INQ_VARID(nid,"ug",var3didin(10))
338	if(ierr/=NF_NOERR) then
339	write(,) NF_STRERROR(ierr)
340	stop 'ug'
341	endif
342
343	ierr=NF_INQ_VARID(nid,"vg",var3didin(11))
344	if(ierr/=NF_NOERR) then
345	write(,) NF_STRERROR(ierr)
346	stop 'vg'
347	endif
348
349	ierr=NF_INQ_VARID(nid,"w",var3didin(12))
350	if(ierr/=NF_NOERR) then
351	write(,) NF_STRERROR(ierr)
352	stop 'w'
353	endif
354
355	ierr=NF_INQ_VARID(nid,"advu",var3didin(13))
356	if(ierr/=NF_NOERR) then
357	write(,) NF_STRERROR(ierr)
358	stop 'advu'
359	endif
360
361	ierr=NF_INQ_VARID(nid,"hu",var3didin(14))
362	if(ierr/=NF_NOERR) then
363	write(,) NF_STRERROR(ierr)
364	stop 'hu'
365	endif
366
367	ierr=NF_INQ_VARID(nid,"vu",var3didin(15))
368	if(ierr/=NF_NOERR) then
369	write(,) NF_STRERROR(ierr)
370	stop 'vu'
371	endif
372
373	ierr=NF_INQ_VARID(nid,"advv",var3didin(16))
374	if(ierr/=NF_NOERR) then
375	write(,) NF_STRERROR(ierr)
376	stop 'advv'
377	endif
378
379	ierr=NF_INQ_VARID(nid,"hv",var3didin(17))
380	if(ierr/=NF_NOERR) then
381	write(,) NF_STRERROR(ierr)
382	stop 'hv'
383	endif
384
385	ierr=NF_INQ_VARID(nid,"vv",var3didin(18))
386	if(ierr/=NF_NOERR) then
387	write(,) NF_STRERROR(ierr)
388	stop 'vv'
389	endif
390
391	ierr=NF_INQ_VARID(nid,"advT",var3didin(19))
392	if(ierr/=NF_NOERR) then
393	write(,) NF_STRERROR(ierr)
394	stop 'advT'
395	endif
396
397	ierr=NF_INQ_VARID(nid,"hT",var3didin(20))
398	if(ierr/=NF_NOERR) then
399	write(,) NF_STRERROR(ierr)
400	stop 'hT'
401	endif
402
403	ierr=NF_INQ_VARID(nid,"vT",var3didin(21))
404	if(ierr/=NF_NOERR) then
405	write(,) NF_STRERROR(ierr)
406	stop 'vT'
407	endif
408
409	ierr=NF_INQ_VARID(nid,"advq",var3didin(22))
410	if(ierr/=NF_NOERR) then
411	write(,) NF_STRERROR(ierr)
412	stop 'advq'
413	endif
414
415	ierr=NF_INQ_VARID(nid,"hq",var3didin(23))
416	if(ierr/=NF_NOERR) then
417	write(,) NF_STRERROR(ierr)
418	stop 'hq'
419	endif
420
421	ierr=NF_INQ_VARID(nid,"vq",var3didin(24))
422	if(ierr/=NF_NOERR) then
423	write(,) NF_STRERROR(ierr)
424	stop 'vq'
425	endif
426
427	ierr=NF_INQ_VARID(nid,"advth",var3didin(25))
428	if(ierr/=NF_NOERR) then
429	write(,) NF_STRERROR(ierr)
430	stop 'advth'
431	endif
432
433	ierr=NF_INQ_VARID(nid,"hth",var3didin(26))
434	if(ierr/=NF_NOERR) then
435	write(,) NF_STRERROR(ierr)
436	stop 'hth'
437	endif
438
439	ierr=NF_INQ_VARID(nid,"vth",var3didin(27))
440	if(ierr/=NF_NOERR) then
441	write(,) NF_STRERROR(ierr)
442	stop 'vth'
443	endif
444
445	ierr=NF_INQ_VARID(nid,"advr",var3didin(28))
446	if(ierr/=NF_NOERR) then
447	write(,) NF_STRERROR(ierr)
448	stop 'advr'
449	endif
450
451	ierr=NF_INQ_VARID(nid,"hr",var3didin(29))
452	if(ierr/=NF_NOERR) then
453	write(,) NF_STRERROR(ierr)
454	stop 'hr'
455	endif
456
457	ierr=NF_INQ_VARID(nid,"vr",var3didin(30))
458	if(ierr/=NF_NOERR) then
459	write(,) NF_STRERROR(ierr)
460	stop 'vr'
461	endif
462
463	ierr=NF_INQ_VARID(nid,"radT",var3didin(31))
464	if(ierr/=NF_NOERR) then
465	write(,) NF_STRERROR(ierr)
466	stop 'radT'
467	endif
468
469	ierr=NF_INQ_VARID(nid,"sens",var3didin(32))
470	if(ierr/=NF_NOERR) then
471	write(,) NF_STRERROR(ierr)
472	stop 'sens'
473	endif
474
475	ierr=NF_INQ_VARID(nid,"flat",var3didin(33))
476	if(ierr/=NF_NOERR) then
477	write(,) NF_STRERROR(ierr)
478	stop 'flat'
479	endif
480
481	ierr=NF_INQ_VARID(nid,"ts",var3didin(34))
482	if(ierr/=NF_NOERR) then
483	write(,) NF_STRERROR(ierr)
484	stop 'ts'
485	endif
486
487	ierr=NF_INQ_VARID(nid,"ustar",var3didin(35))
488	if(ierr/=NF_NOERR) then
489	write(,) NF_STRERROR(ierr)
490	stop 'ustar'
491	endif
492
493	#ifdef NC_DOUBLE
494	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz)
495	#else
496	ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz)
497	#endif
498	if(ierr/=NF_NOERR) then
499	write(,) NF_STRERROR(ierr)
500	stop "getvarup"
501	endif
502	! write(,)'lecture z ok',zz
503
504	#ifdef NC_DOUBLE
505	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),pp)
506	#else
507	ierr = NF_GET_VAR_REAL(nid,var3didin(2),pp)
508	#endif
509	if(ierr/=NF_NOERR) then
510	write(,) NF_STRERROR(ierr)
511	stop "getvarup"
512	endif
513	! write(,)'lecture pp ok',pp
514
515
516	#ifdef NC_DOUBLE
517	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),temp)
518	#else
519	ierr = NF_GET_VAR_REAL(nid,var3didin(3),temp)
520	#endif
521	if(ierr/=NF_NOERR) then
522	write(,) NF_STRERROR(ierr)
523	stop "getvarup"
524	endif
525	! write(,)'lecture T ok',temp
526
527	#ifdef NC_DOUBLE
528	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),qv)
529	#else
530	ierr = NF_GET_VAR_REAL(nid,var3didin(4),qv)
531	#endif
532	if(ierr/=NF_NOERR) then
533	write(,) NF_STRERROR(ierr)
534	stop "getvarup"
535	endif
536	! write(,)'lecture qv ok',qv
537
538	#ifdef NC_DOUBLE
539	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),rh)
540	#else
541	ierr = NF_GET_VAR_REAL(nid,var3didin(5),rh)
542	#endif
543	if(ierr/=NF_NOERR) then
544	write(,) NF_STRERROR(ierr)
545	stop "getvarup"
546	endif
547	! write(,)'lecture rh ok',rh
548
549	#ifdef NC_DOUBLE
550	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),theta)
551	#else
552	ierr = NF_GET_VAR_REAL(nid,var3didin(6),theta)
553	#endif
554	if(ierr/=NF_NOERR) then
555	write(,) NF_STRERROR(ierr)
556	stop "getvarup"
557	endif
558	! write(,)'lecture theta ok',theta
559
560	#ifdef NC_DOUBLE
561	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),rv)
562	#else
563	ierr = NF_GET_VAR_REAL(nid,var3didin(7),rv)
564	#endif
565	if(ierr/=NF_NOERR) then
566	write(,) NF_STRERROR(ierr)
567	stop "getvarup"
568	endif
569	! write(,)'lecture rv ok',rv
570
571	#ifdef NC_DOUBLE
572	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),u)
573	#else
574	ierr = NF_GET_VAR_REAL(nid,var3didin(8),u)
575	#endif
576	if(ierr/=NF_NOERR) then
577	write(,) NF_STRERROR(ierr)
578	stop "getvarup"
579	endif
580	! write(,)'lecture u ok',u
581
582	#ifdef NC_DOUBLE
583	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),v)
584	#else
585	ierr = NF_GET_VAR_REAL(nid,var3didin(9),v)
586	#endif
587	if(ierr/=NF_NOERR) then
588	write(,) NF_STRERROR(ierr)
589	stop "getvarup"
590	endif
591	! write(,)'lecture v ok',v
592
593	#ifdef NC_DOUBLE
594	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),ug)
595	#else
596	ierr = NF_GET_VAR_REAL(nid,var3didin(10),ug)
597	#endif
598	if(ierr/=NF_NOERR) then
599	write(,) NF_STRERROR(ierr)
600	stop "getvarup"
601	endif
602	! write(,)'lecture ug ok',ug
603
604	#ifdef NC_DOUBLE
605	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),vg)
606	#else
607	ierr = NF_GET_VAR_REAL(nid,var3didin(11),vg)
608	#endif
609	if(ierr/=NF_NOERR) then
610	write(,) NF_STRERROR(ierr)
611	stop "getvarup"
612	endif
613	! write(,)'lecture vg ok',vg
614
615	#ifdef NC_DOUBLE
616	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),w)
617	#else
618	ierr = NF_GET_VAR_REAL(nid,var3didin(12),w)
619	#endif
620	if(ierr/=NF_NOERR) then
621	write(,) NF_STRERROR(ierr)
622	stop "getvarup"
623	endif
624	! write(,)'lecture w ok',w
625
626	#ifdef NC_DOUBLE
627	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),du)
628	#else
629	ierr = NF_GET_VAR_REAL(nid,var3didin(13),du)
630	#endif
631	if(ierr/=NF_NOERR) then
632	write(,) NF_STRERROR(ierr)
633	stop "getvarup"
634	endif
635	! write(,)'lecture du ok',du
636
637	#ifdef NC_DOUBLE
638	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),hu)
639	#else
640	ierr = NF_GET_VAR_REAL(nid,var3didin(14),hu)
641	#endif
642	if(ierr/=NF_NOERR) then
643	write(,) NF_STRERROR(ierr)
644	stop "getvarup"
645	endif
646	! write(,)'lecture hu ok',hu
647
648	#ifdef NC_DOUBLE
649	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),vu)
650	#else
651	ierr = NF_GET_VAR_REAL(nid,var3didin(15),vu)
652	#endif
653	if(ierr/=NF_NOERR) then
654	write(,) NF_STRERROR(ierr)
655	stop "getvarup"
656	endif
657	! write(,)'lecture vu ok',vu
658
659	#ifdef NC_DOUBLE
660	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),dv)
661	#else
662	ierr = NF_GET_VAR_REAL(nid,var3didin(16),dv)
663	#endif
664	if(ierr/=NF_NOERR) then
665	write(,) NF_STRERROR(ierr)
666	stop "getvarup"
667	endif
668	! write(,)'lecture dv ok',dv
669
670	#ifdef NC_DOUBLE
671	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(17),hv)
672	#else
673	ierr = NF_GET_VAR_REAL(nid,var3didin(17),hv)
674	#endif
675	if(ierr/=NF_NOERR) then
676	write(,) NF_STRERROR(ierr)
677	stop "getvarup"
678	endif
679	! write(,)'lecture hv ok',hv
680
681	#ifdef NC_DOUBLE
682	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(18),vv)
683	#else
684	ierr = NF_GET_VAR_REAL(nid,var3didin(18),vv)
685	#endif
686	if(ierr/=NF_NOERR) then
687	write(,) NF_STRERROR(ierr)
688	stop "getvarup"
689	endif
690	! write(,)'lecture vv ok',vv
691
692	#ifdef NC_DOUBLE
693	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(19),dt)
694	#else
695	ierr = NF_GET_VAR_REAL(nid,var3didin(19),dt)
696	#endif
697	if(ierr/=NF_NOERR) then
698	write(,) NF_STRERROR(ierr)
699	stop "getvarup"
700	endif
701	! write(,)'lecture dt ok',dt
702
703	#ifdef NC_DOUBLE
704	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(20),ht)
705	#else
706	ierr = NF_GET_VAR_REAL(nid,var3didin(20),ht)
707	#endif
708	if(ierr/=NF_NOERR) then
709	write(,) NF_STRERROR(ierr)
710	stop "getvarup"
711	endif
712	! write(,)'lecture ht ok',ht
713
714	#ifdef NC_DOUBLE
715	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(21),vt)
716	#else
717	ierr = NF_GET_VAR_REAL(nid,var3didin(21),vt)
718	#endif
719	if(ierr/=NF_NOERR) then
720	write(,) NF_STRERROR(ierr)
721	stop "getvarup"
722	endif
723	! write(,)'lecture vt ok',vt
724
725	#ifdef NC_DOUBLE
726	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(22),dq)
727	#else
728	ierr = NF_GET_VAR_REAL(nid,var3didin(22),dq)
729	#endif
730	if(ierr/=NF_NOERR) then
731	write(,) NF_STRERROR(ierr)
732	stop "getvarup"
733	endif
734	! write(,)'lecture dq ok',dq
735
736	#ifdef NC_DOUBLE
737	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(23),hq)
738	#else
739	ierr = NF_GET_VAR_REAL(nid,var3didin(23),hq)
740	#endif
741	if(ierr/=NF_NOERR) then
742	write(,) NF_STRERROR(ierr)
743	stop "getvarup"
744	endif
745	! write(,)'lecture hq ok',hq
746
747	#ifdef NC_DOUBLE
748	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(24),vq)
749	#else
750	ierr = NF_GET_VAR_REAL(nid,var3didin(24),vq)
751	#endif
752	if(ierr/=NF_NOERR) then
753	write(,) NF_STRERROR(ierr)
754	stop "getvarup"
755	endif
756	! write(,)'lecture vq ok',vq
757
758	#ifdef NC_DOUBLE
759	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(25),dth)
760	#else
761	ierr = NF_GET_VAR_REAL(nid,var3didin(25),dth)
762	#endif
763	if(ierr/=NF_NOERR) then
764	write(,) NF_STRERROR(ierr)
765	stop "getvarup"
766	endif
767	! write(,)'lecture dth ok',dth
768
769	#ifdef NC_DOUBLE
770	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(26),hth)
771	#else
772	ierr = NF_GET_VAR_REAL(nid,var3didin(26),hth)
773	#endif
774	if(ierr/=NF_NOERR) then
775	write(,) NF_STRERROR(ierr)
776	stop "getvarup"
777	endif
778	! write(,)'lecture hth ok',hth
779
780	#ifdef NC_DOUBLE
781	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(27),vth)
782	#else
783	ierr = NF_GET_VAR_REAL(nid,var3didin(27),vth)
784	#endif
785	if(ierr/=NF_NOERR) then
786	write(,) NF_STRERROR(ierr)
787	stop "getvarup"
788	endif
789	! write(,)'lecture vth ok',vth
790
791	#ifdef NC_DOUBLE
792	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(28),dr)
793	#else
794	ierr = NF_GET_VAR_REAL(nid,var3didin(28),dr)
795	#endif
796	if(ierr/=NF_NOERR) then
797	write(,) NF_STRERROR(ierr)
798	stop "getvarup"
799	endif
800	! write(,)'lecture dr ok',dr
801
802	#ifdef NC_DOUBLE
803	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(29),hr)
804	#else
805	ierr = NF_GET_VAR_REAL(nid,var3didin(29),hr)
806	#endif
807	if(ierr/=NF_NOERR) then
808	write(,) NF_STRERROR(ierr)
809	stop "getvarup"
810	endif
811	! write(,)'lecture hr ok',hr
812
813	#ifdef NC_DOUBLE
814	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(30),vr)
815	#else
816	ierr = NF_GET_VAR_REAL(nid,var3didin(30),vr)
817	#endif
818	if(ierr/=NF_NOERR) then
819	write(,) NF_STRERROR(ierr)
820	stop "getvarup"
821	endif
822	! write(,)'lecture vr ok',vr
823
824	#ifdef NC_DOUBLE
825	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(31),dtrad)
826	#else
827	ierr = NF_GET_VAR_REAL(nid,var3didin(31),dtrad)
828	#endif
829	if(ierr/=NF_NOERR) then
830	write(,) NF_STRERROR(ierr)
831	stop "getvarup"
832	endif
833	! write(,)'lecture dtrad ok',dtrad
834
835	#ifdef NC_DOUBLE
836	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(32),sens)
837	#else
838	ierr = NF_GET_VAR_REAL(nid,var3didin(32),sens)
839	#endif
840	if(ierr/=NF_NOERR) then
841	write(,) NF_STRERROR(ierr)
842	stop "getvarup"
843	endif
844	! write(,)'lecture sens ok',sens
845
846	#ifdef NC_DOUBLE
847	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(33),flat)
848	#else
849	ierr = NF_GET_VAR_REAL(nid,var3didin(33),flat)
850	#endif
851	if(ierr/=NF_NOERR) then
852	write(,) NF_STRERROR(ierr)
853	stop "getvarup"
854	endif
855	! write(,)'lecture flat ok',flat
856
857	#ifdef NC_DOUBLE
858	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(34),ts)
859	#else
860	ierr = NF_GET_VAR_REAL(nid,var3didin(34),ts)
861	#endif
862	if(ierr/=NF_NOERR) then
863	write(,) NF_STRERROR(ierr)
864	stop "getvarup"
865	endif
866	! write(,)'lecture ts ok',ts
867
868	#ifdef NC_DOUBLE
869	ierr = NF_GET_VAR_DOUBLE(nid,var3didin(35),ustar)
870	#else
871	ierr = NF_GET_VAR_REAL(nid,var3didin(35),ustar)
872	#endif
873	if(ierr/=NF_NOERR) then
874	write(,) NF_STRERROR(ierr)
875	stop "getvarup"
876	endif
877	! write(,)'lecture ustar ok',ustar
878
879
880	return
881	end subroutine read_cas
882	!======================================================================
883	SUBROUTINE interp_case_time(day,day1,annee_ref &
884	& ,year_ini_cas,day_ini_cas,nt_cas,pdt_cas,nlev_cas &
885	& ,ts_cas,plev_cas,t_cas,q_cas,u_cas,v_cas &
886	& ,ug_cas,vg_cas,vitw_cas,du_cas,hu_cas,vu_cas &
887	& ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas &
888	& ,dq_cas,hq_cas,vq_cas,lat_cas,sens_cas,ustar_cas &
889	& ,ts_prof_cas,plev_prof_cas,t_prof_cas,q_prof_cas &
890	& ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas &
891	& ,vitw_prof_cas,du_prof_cas,hu_prof_cas,vu_prof_cas &
892	& ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas &
893	& ,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas &
894	& ,hq_prof_cas,vq_prof_cas,lat_prof_cas,sens_prof_cas,ustar_prof_cas)
895
896
897	implicit none
898
899	!---------------------------------------------------------------------------------------
900	! Time interpolation of a 2D field to the timestep corresponding to day
901	!
902	! day: current julian day (e.g. 717538.2)
903	! day1: first day of the simulation
904	! nt_cas: total nb of data in the forcing
905	! pdt_cas: total time interval (in sec) between 2 forcing data
906	!---------------------------------------------------------------------------------------
907
908	#include "compar1d.h"
909
910	! inputs:
911	integer annee_ref
912	integer nt_cas,nlev_cas
913	integer year_ini_cas
914	real day_ini_cas
915	real day, day1,pdt_cas
916	real ts_cas(nt_cas)
917	real plev_cas(nlev_cas,nt_cas)
918	real t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas)
919	real u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas)
920	real ug_cas(nlev_cas,nt_cas),vg_cas(nlev_cas,nt_cas)
921	real vitw_cas(nlev_cas,nt_cas)
922	real du_cas(nlev_cas,nt_cas),hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas)
923	real dv_cas(nlev_cas,nt_cas),hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas)
924	real dt_cas(nlev_cas,nt_cas),ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas)
925	real dtrad_cas(nlev_cas,nt_cas)
926	real dq_cas(nlev_cas,nt_cas),hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas)
927	real lat_cas(nt_cas)
928	real sens_cas(nt_cas)
929	real ustar_cas(nt_cas)
930
931	! outputs:
932	real plev_prof_cas(nlev_cas)
933	real t_prof_cas(nlev_cas),q_prof_cas(nlev_cas)
934	real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)
935	real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas)
936	real vitw_prof_cas(nlev_cas)
937	real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)
938	real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)
939	real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas)
940	real dtrad_prof_cas(nlev_cas)
941	real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)
942	real lat_prof_cas,sens_prof_cas,ts_prof_cas,ustar_prof_cas
943	! local:
944	integer it_cas1, it_cas2,k
945	real timeit,time_cas1,time_cas2,frac
946
947
948	print*,'Check time',day1,day_ini_cas,day_ini_cas+1
949
950	! On teste si la date du cas AMMA est correcte.
951	! C est pour memoire car en fait les fichiers .def
952	! sont censes etre corrects.
953	! A supprimer a terme (MPL 20150623)
954	if ((forcing_type.eq.10).and.(1.eq.0)) then
955	! Check that initial day of the simulation consistent with AMMA case:
956	if (annee_ref.ne.2006) then
957	print*,'Pour AMMA, annee_ref doit etre 2006'
958	print*,'Changer annee_ref dans run.def'
959	stop
960	endif
961	if (annee_ref.eq.2006 .and. day1.lt.day_ini_cas) then
962	print*,'AMMA a debute le 10 juillet 2006',day1,day_ini_cas
963	print*,'Changer dayref dans run.def'
964	stop
965	endif
966	if (annee_ref.eq.2006 .and. day1.gt.day_ini_cas+1) then
967	print*,'AMMA a fini le 11 juillet'
968	print*,'Changer dayref ou nday dans run.def'
969	stop
970	endif
971	endif
972
973	! Determine timestep relative to the 1st day:
974	! timeit=(day-day1)*86400.
975	! if (annee_ref.eq.1992) then
976	! timeit=(day-day_ini_cas)*86400.
977	! else
978	! timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
979	! endif
980	timeit=(day-day_ini_cas)*86400
981
982	! Determine the closest observation times:
983	! it_cas1=INT(timeit/pdt_cas)+1
984	! it_cas2=it_cas1 + 1
985	! time_cas1=(it_cas1-1)*pdt_cas
986	! time_cas2=(it_cas2-1)*pdt_cas
987
988	it_cas1=INT(timeit/pdt_cas)+1
989	IF (it_cas1 .EQ. nt_cas) THEN
990	it_cas2=it_cas1
991	ELSE
992	it_cas2=it_cas1 + 1
993	ENDIF
994	time_cas1=(it_cas1-1)*pdt_cas
995	time_cas2=(it_cas2-1)*pdt_cas
996
997	if (it_cas1 .gt. nt_cas) then
998	write(,) 'PB-stop: day, it_cas1, it_cas2, timeit: ' &
999	& ,day,day_ini_cas,it_cas1,it_cas2,timeit/86400.
1000	stop
1001	endif
1002
1003	! time interpolation:
1004	frac=(time_cas2-timeit)/(time_cas2-time_cas1)
1005	frac=max(frac,0.0)
1006
1007	lat_prof_cas = lat_cas(it_cas2) &
1008	& -frac*(lat_cas(it_cas2)-lat_cas(it_cas1))
1009	sens_prof_cas = sens_cas(it_cas2) &
1010	& -frac*(sens_cas(it_cas2)-sens_cas(it_cas1))
1011	ts_prof_cas = ts_cas(it_cas2) &
1012	& -frac*(ts_cas(it_cas2)-ts_cas(it_cas1))
1013	ustar_prof_cas = ustar_cas(it_cas2) &
1014	& -frac*(ustar_cas(it_cas2)-ustar_cas(it_cas1))
1015
1016	do k=1,nlev_cas
1017	plev_prof_cas(k) = plev_cas(k,it_cas2) &
1018	& -frac*(plev_cas(k,it_cas2)-plev_cas(k,it_cas1))
1019	t_prof_cas(k) = t_cas(k,it_cas2) &
1020	& -frac*(t_cas(k,it_cas2)-t_cas(k,it_cas1))
1021	q_prof_cas(k) = q_cas(k,it_cas2) &
1022	& -frac*(q_cas(k,it_cas2)-q_cas(k,it_cas1))
1023	u_prof_cas(k) = u_cas(k,it_cas2) &
1024	& -frac*(u_cas(k,it_cas2)-u_cas(k,it_cas1))
1025	v_prof_cas(k) = v_cas(k,it_cas2) &
1026	& -frac*(v_cas(k,it_cas2)-v_cas(k,it_cas1))
1027	ug_prof_cas(k) = ug_cas(k,it_cas2) &
1028	& -frac*(ug_cas(k,it_cas2)-ug_cas(k,it_cas1))
1029	vg_prof_cas(k) = vg_cas(k,it_cas2) &
1030	& -frac*(vg_cas(k,it_cas2)-vg_cas(k,it_cas1))
1031	vitw_prof_cas(k) = vitw_cas(k,it_cas2) &
1032	& -frac*(vitw_cas(k,it_cas2)-vitw_cas(k,it_cas1))
1033	du_prof_cas(k) = du_cas(k,it_cas2) &
1034	& -frac*(du_cas(k,it_cas2)-du_cas(k,it_cas1))
1035	hu_prof_cas(k) = hu_cas(k,it_cas2) &
1036	& -frac*(hu_cas(k,it_cas2)-hu_cas(k,it_cas1))
1037	vu_prof_cas(k) = vu_cas(k,it_cas2) &
1038	& -frac*(vu_cas(k,it_cas2)-vu_cas(k,it_cas1))
1039	dv_prof_cas(k) = dv_cas(k,it_cas2) &
1040	& -frac*(dv_cas(k,it_cas2)-dv_cas(k,it_cas1))
1041	hv_prof_cas(k) = hv_cas(k,it_cas2) &
1042	& -frac*(hv_cas(k,it_cas2)-hv_cas(k,it_cas1))
1043	vv_prof_cas(k) = vv_cas(k,it_cas2) &
1044	& -frac*(vv_cas(k,it_cas2)-vv_cas(k,it_cas1))
1045	dt_prof_cas(k) = dt_cas(k,it_cas2) &
1046	& -frac*(dt_cas(k,it_cas2)-dt_cas(k,it_cas1))
1047	ht_prof_cas(k) = ht_cas(k,it_cas2) &
1048	& -frac*(ht_cas(k,it_cas2)-ht_cas(k,it_cas1))
1049	vt_prof_cas(k) = vt_cas(k,it_cas2) &
1050	& -frac*(vt_cas(k,it_cas2)-vt_cas(k,it_cas1))
1051	dtrad_prof_cas(k) = dtrad_cas(k,it_cas2) &
1052	& -frac*(dtrad_cas(k,it_cas2)-dtrad_cas(k,it_cas1))
1053	dq_prof_cas(k) = dq_cas(k,it_cas2) &
1054	& -frac*(dq_cas(k,it_cas2)-dq_cas(k,it_cas1))
1055	hq_prof_cas(k) = hq_cas(k,it_cas2) &
1056	& -frac*(hq_cas(k,it_cas2)-hq_cas(k,it_cas1))
1057	vq_prof_cas(k) = vq_cas(k,it_cas2) &
1058	& -frac*(vq_cas(k,it_cas2)-vq_cas(k,it_cas1))
1059	enddo
1060
1061	return
1062	END
1063
1064	!**********************************************************************************************

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

Download in other formats:

Original Format