source: LMDZ4/trunk/libf/phytherm/surf_land_bucket_mod.F90 @ 1018

Last change on this file since 1018 was 814, checked in by Laurent Fairhead, 17 years ago

Rajout de la physique utilisant les thermiques FH
LF
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.6 KB
Line 
1!
2! $Header$
3!
4MODULE surf_land_bucket_mod
5!
6! Surface land bucket module
7!
8! This module is used when no external land model is choosen.
9!
10  USE fonte_neige_mod
11  USE calcul_fluxs_mod
12  USE dimphy
13  USE mod_grid_phy_lmdz
14  USE mod_phys_lmdz_para
15 
16  IMPLICIT NONE
17
18CONTAINS
19
20  SUBROUTINE surf_land_bucket(itime, jour, knon, knindex, debut, dtime,&
21       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, &
22       spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, ps, &
23       u1_lay, v1_lay, rugoro, &
24       radsol, snow, qsol, agesno, tsoil, &
25       qsurf, z0_new, alblw, evap, fluxsens, fluxlat, &
26       tsurf_new, alb_new, dflux_s, dflux_l)
27
28!****************************************************************************************
29! Bucket calculations for surface.
30!
31    INCLUDE "clesphys.h"
32    INCLUDE "indicesol.h"
33    INCLUDE "dimsoil.h"
34    INCLUDE "YOMCST.h"
35
36! Input variables 
37!****************************************************************************************
38    INTEGER, INTENT(IN)                     :: itime, jour, knon
39    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
40    LOGICAL, INTENT(IN)                     :: debut
41    REAL, INTENT(IN)                        :: dtime
42    REAL, DIMENSION(klon), INTENT(IN)       :: tsurf
43    REAL, DIMENSION(klon), INTENT(IN)       :: p1lay
44    REAL, DIMENSION(klon), INTENT(IN)       :: tq_cdrag
45    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
46    REAL, DIMENSION(klon), INTENT(IN)       :: temp_air, spechum
47    REAL, DIMENSION(klon), INTENT(IN)       :: petAcoef, peqAcoef
48    REAL, DIMENSION(klon), INTENT(IN)       :: petBcoef, peqBcoef
49    REAL, DIMENSION(klon), INTENT(IN)       :: ps
50    REAL, DIMENSION(klon), INTENT(IN)       :: u1_lay, v1_lay
51    REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
52
53! In/Output variables
54!****************************************************************************************
55    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
56    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
57    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
58    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
59
60! Output variables
61!****************************************************************************************
62    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
63    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
64    REAL, DIMENSION(klon), INTENT(OUT)       :: alblw
65    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
66    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new, alb_new
67    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l     
68
69! Local variables
70!****************************************************************************************
71    REAL, DIMENSION(klon) :: soilcap, soilflux
72    REAL, DIMENSION(klon) :: cal, beta, dif_grnd, capsol
73    REAL, DIMENSION(klon) :: alb_neig
74    REAL, DIMENSION(klon) :: zfra
75    INTEGER               :: i
76!
77!****************************************************************************************
78
79
80!
81!* Read from limit.nc : albedo(alb_new), length of rugosity(z0_new)
82!
83    CALL interfsur_lim(itime, dtime, jour, &
84         knon, knindex, debut,  &
85         alb_new, z0_new)
86   
87!
88!* Calcultaion of fluxes
89!
90! calculate constants
91    CALL calbeta(dtime, is_ter, knon, snow, qsol, beta, capsol, dif_grnd)
92       
93! calculate temperature, heat capacity and conduction flux in soil
94    IF (soil_model) THEN
95       CALL soil(dtime, is_ter, knon, snow, tsurf, tsoil, soilcap, soilflux)
96       DO i=1, knon
97          cal(i) = RCPD / soilcap(i)
98          radsol(i) = radsol(i)  + soilflux(i)
99       END DO
100    ELSE
101       cal(:) = RCPD * capsol(:)
102    ENDIF
103   
104    CALL calcul_fluxs(knon, is_ter, dtime, &
105         tsurf, p1lay, cal, beta, tq_cdrag, ps, &
106         precip_rain, precip_snow, snow, qsurf,  &
107         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
108         petAcoef, peqAcoef, petBcoef, peqBcoef, &
109         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
110   
111!
112!* Calculate snow height, run_off, age of snow
113!     
114    CALL fonte_neige( knon, is_ter, knindex, dtime, &
115         tsurf, precip_rain, precip_snow, &
116         snow, qsol, tsurf_new, evap)
117!
118!* Calculate the age of snow
119!
120    CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:)) 
121   
122    WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
123   
124    DO i=1, knon
125       zfra(i) = MAX(0.0,MIN(1.0, snow(i)/(snow(i)+10.0)))
126       alb_new(i)  = alb_neig(i) *zfra(i) + alb_new(i)*(1.0-zfra(i))
127    END DO
128
129    alblw(:) = 0.0
130    alblw(1:knon) = alb_new(1:knon)
131
132!
133!* Calculate the rugosity
134!
135    z0_new = SQRT(z0_new**2+rugoro**2)
136       
137!
138!* End
139!
140  END SUBROUTINE surf_land_bucket
141!
142!****************************************************************************************
143!
144  SUBROUTINE interfsur_lim(itime, dtime, jour, &
145       knon, knindex, debut, &
146       lmt_alb_p, lmt_rug_p)
147   
148! Cette routine sert d'interface entre le modele atmospherique et un fichier
149! de conditions aux limites
150!
151! L. Fairhead 02/2000
152!
153! input:
154!   itime        numero du pas de temps courant
155!   dtime        pas de temps de la physique (en s)
156!   jour         jour a lire dans l'annee
157!   knon         nombre de points dans le domaine a traiter
158!   knindex      index des points de la surface a traiter
159!   debut        logical: 1er appel a la physique (initialisation)
160!
161! output:
162!   lmt_alb_p      Albedo lu
163!   lmt_rug_p      longueur de rugosite lue
164
165    INCLUDE "netcdf.inc"
166
167! Input variables
168!****************************************************************************************
169    INTEGER, INTENT(IN)                      :: itime
170    REAL   , INTENT(IN)                      :: dtime
171    INTEGER, INTENT(IN)                      :: jour
172    INTEGER, INTENT(IN)                      :: knon
173    INTEGER, DIMENSION(klon_loc), INTENT(IN) :: knindex
174    LOGICAL, INTENT(IN)                      :: debut
175
176! Output variables
177!****************************************************************************************
178    REAL, INTENT(out), DIMENSION(klon_loc)   :: lmt_alb_p
179    REAL, INTENT(out), DIMENSION(klon_loc)   :: lmt_rug_p
180
181! Local variables with attribute SAVE
182!****************************************************************************************
183    INTEGER,SAVE   :: lmt_pas     ! frequence de lecture des conditions limites
184                                  ! (en pas de physique)
185    !$OMP THREADPRIVATE(lmt_pas)
186    LOGICAL,SAVE   :: deja_lu_sur ! pour indiquer que le jour a lire a deja
187                                  ! lu pour une surface precedente
188    !$OMP THREADPRIVATE(deja_lu_sur)
189    INTEGER,SAVE                           :: jour_lu_sur
190    !$OMP THREADPRIVATE(jour_lu_sur)
191    CHARACTER (len = 20),SAVE              :: fich ='limit.nc'
192    !$OMP THREADPRIVATE(fich)
193    LOGICAL,SAVE                           :: check = .FALSE.
194    !$OMP THREADPRIVATE(check)
195! Champs lus dans le fichier de CL
196    REAL, ALLOCATABLE , SAVE, DIMENSION(:) :: alb_lu_p, rug_lu_p
197    !$OMP THREADPRIVATE(alb_lu_p, rug_lu_p)
198
199! quelques variables pour netcdf
200    INTEGER ,SAVE                          :: nid, nvarid
201    !$OMP THREADPRIVATE(nid, nvarid)
202    INTEGER, DIMENSION(2),SAVE             :: start, epais
203    !$OMP THREADPRIVATE(start, epais)
204
205! Other local variables
206!****************************************************************************************
207    INTEGER                                :: ii, ierr
208    CHARACTER (len = 20)                   :: modname = 'interfsur_lim'
209    CHARACTER (len = 80)                   :: abort_message
210    REAL, DIMENSION(klon_glo)              :: alb_lu
211    REAL, DIMENSION(klon_glo)              :: rug_lu
212
213!
214! End delaration
215!****************************************************************************************
216
217    IF (debut) THEN
218       lmt_pas = NINT(86400./dtime * 1.0) ! pour une lecture une fois par jour
219       jour_lu_sur = jour - 1
220       ALLOCATE(alb_lu_p(klon_loc))
221       ALLOCATE(rug_lu_p(klon_loc))
222    ENDIF
223   
224    IF ((jour - jour_lu_sur) /= 0) deja_lu_sur = .FALSE.
225 
226    IF (check) WRITE(*,*) modname,':: jour_lu_sur, deja_lu_sur', jour_lu_sur, deja_lu_sur
227    IF (check) WRITE(*,*) modname,':: itime, lmt_pas', itime, lmt_pas
228    IF (check) CALL flush(6)
229
230!   
231! Tester d'abord si c'est le moment de lire le fichier
232!
233    IF (MOD(itime-1, lmt_pas) == 0 .AND. .NOT. deja_lu_sur) THEN
234
235!
236! Ouverture et lecture du fichier
237!
238!$OMP MASTER
239       IF (is_mpi_root) THEN
240          fich = TRIM(fich)
241          IF (check) WRITE(*,*)modname,' ouverture fichier ',fich
242          IF (check) CALL flush(6)
243          ierr = NF_OPEN (fich, NF_NOWRITE,nid)
244          IF (ierr.NE.NF_NOERR) THEN
245             abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
246             CALL abort_gcm(modname,abort_message,1)
247          ENDIF
248!
249! La tranche de donnees a lire:
250          start(1) = 1
251          start(2) = jour
252          epais(1) = klon_glo
253          epais(2) = 1
254!
255! Lecture albedo
256          ierr = NF_INQ_VARID(nid, 'ALB', nvarid)
257          IF (ierr /= NF_NOERR) THEN
258             abort_message = 'Le champ <ALB> est absent'
259             CALL abort_gcm(modname,abort_message,1)
260          ENDIF
261#ifdef NC_DOUBLE
262          ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, alb_lu)
263#else
264          ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, alb_lu)
265#endif
266          IF (ierr /= NF_NOERR) THEN
267             abort_message = 'Lecture echouee pour <ALB>'
268             CALL abort_gcm(modname,abort_message,1)
269          ENDIF
270!
271! Lecture rugosite!
272          ierr = NF_INQ_VARID(nid, 'RUG', nvarid)
273          IF (ierr /= NF_NOERR) THEN
274             abort_message = 'Le champ <RUG> est absent'
275             CALL abort_gcm(modname,abort_message,1)
276          ENDIF
277#ifdef NC_DOUBLE
278          ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, rug_lu)
279#else
280          ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, rug_lu)
281#endif
282          IF (ierr /= NF_NOERR) THEN
283             abort_message = 'Lecture echouee pour <RUG>'
284             CALL abort_gcm(modname,abort_message,1)
285          ENDIF
286
287!
288! Fin de lecture
289          ierr = NF_CLOSE(nid)
290
291       ENDIF ! is_mpi_root
292!$OMP END MASTER
293
294       CALL Scatter(alb_lu,alb_lu_p)
295       CALL Scatter(rug_lu,rug_lu_p)
296
297       deja_lu_sur = .TRUE.
298       jour_lu_sur = jour       
299
300    ENDIF
301 
302!
303! Recopie des variables dans les champs de sortie
304!
305    lmt_alb_p(:) = 999999.
306    lmt_rug_p(:) = 999999.
307    DO ii = 1, knon
308       lmt_alb_p(ii) = alb_lu_p(knindex(ii))
309       lmt_rug_p(ii) = rug_lu_p(knindex(ii))
310    ENDDO
311   
312
313  END SUBROUTINE interfsur_lim
314!
315!****************************************************************************************
316!
317END MODULE surf_land_bucket_mod
Note: See TracBrowser for help on using the repository browser.