source: LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read.f90 @ 5284

Last change on this file since 5284 was 5270, checked in by abarral, 8 days ago

Replace F77 netcdf library by F90 netcdf library

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