source: LMDZ6/trunk/libf/phylmd/surf_land_mod.F90 @ 5277

Last change on this file since 5277 was 5274, checked in by abarral, 7 hours ago

Replace yomcst.h by existing module
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 16.3 KB
Line 
1!
2MODULE surf_land_mod
3
4  IMPLICIT NONE
5
6CONTAINS
7!
8!****************************************************************************************
9! 
10  SUBROUTINE surf_land(itime, dtime, date0, jour, knon, knindex, &
11       rlon, rlat, yrmu0, &
12       debut, lafin, zlev, ccanopy, swnet, lwnet, albedo, &
13       tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, precip_bs, temp_air, spechum, &
14       AcoefH, AcoefQ, BcoefH, BcoefQ, &
15       AcoefU, AcoefV, BcoefU, BcoefV, &
16       pref, u1, v1, gustiness, rugoro, pctsrf, &
17       lwdown_m, q2m, t2m, &
18       snow, qsol, agesno, tsoil, &
19       z0m, z0h, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, fluxbs, &   
20       qsurf, tsurf_new, dflux_s, dflux_l, &
21       flux_u1, flux_v1 , &
22       veget,lai,height &
23#ifdef ISO
24       ,xtprecip_rain, xtprecip_snow,xtspechum, &
25       xtsnow, xtsol,xtevap,h1, &
26       runoff_diag,xtrunoff_diag,Rland_ice &
27#endif               
28               )
29
30    USE dimphy
31    USE surface_data, ONLY    : ok_veget
32    USE carbon_cycle_mod
33
34
35    ! See comments in each module surf_land_orchidee_xxx for compatiblity with ORCHIDEE
36#ifdef ORCHIDEE_NOOPENMP
37    ! Compilation with cpp key ORCHIDEE NOOPENMP
38    USE surf_land_orchidee_noopenmp_mod
39#else
40#if ORCHIDEE_NOZ0H
41    ! Compilation with cpp key ORCHIDEE NOZ0H
42    USE surf_land_orchidee_noz0h_mod
43#else
44#if ORCHIDEE_NOFREIN
45    ! Compilation with cpp key ORCHIDEE_NOFREIN
46    USE surf_land_orchidee_nofrein_mod
47#else
48#if ORCHIDEE_NOUNSTRUCT
49    ! Compilation with cpp key ORCHIDEE_NOUNSTRUCT
50    USE surf_land_orchidee_nounstruct_mod
51#else
52#if ORCHIDEE_NOLIC
53    ! Compilation with cpp key ORCHIDEE_NOLIC
54    USE surf_land_orchidee_nolic_mod
55#else
56    ! Default version
57    USE surf_land_orchidee_mod
58#endif
59#endif
60#endif
61#endif
62#endif
63   
64    USE surf_land_bucket_mod
65    USE calcul_fluxs_mod
66    USE indice_sol_mod
67#ifdef ISO
68    use infotrac_phy, ONLY: ntiso,niso
69    use isotopes_mod, ONLY: nudge_qsol, iso_eau
70#ifdef ISOVERIF
71    use isotopes_verif_mod
72#endif
73#endif
74
75    USE yomcst_mod_h, ONLY: RPI, RCLUM, RHPLA, RKBOL, RNAVO                   &
76          , RDAY, REA, REPSM, RSIYEA, RSIDAY, ROMEGA                  &
77          , R_ecc, R_peri, R_incl                                      &
78          , RA, RG, R1SA                                         &
79          , RSIGMA                                                     &
80          , R, RMD, RMV, RD, RV, RCPD                    &
81          , RMO3, RMCO2, RMC, RMCH4, RMN2O, RMCFC11, RMCFC12        &
82          , RCPV, RCVD, RCVV, RKAPPA, RETV, eps_w                    &
83          , RCW, RCS                                                 &
84          , RLVTT, RLSTT, RLMLT, RTT, RATM                           &
85          , RESTT, RALPW, RBETW, RGAMW, RALPS, RBETS, RGAMS            &
86          , RALPD, RBETD, RGAMD
87USE print_control_mod, ONLY: lunout
88    USE dimsoil_mod_h, ONLY: nsoilmx
89
90    INCLUDE "clesphys.h"
91    INCLUDE "dimpft.h"
92
93! Input variables 
94!****************************************************************************************
95    INTEGER, INTENT(IN)                     :: itime, jour, knon
96    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
97    REAL, INTENT(IN)                        :: date0
98    REAL, DIMENSION(klon), INTENT(IN)       :: rlon, rlat
99    REAL, DIMENSION(klon), INTENT(IN)       :: yrmu0  ! cosine of solar zenith angle
100    LOGICAL, INTENT(IN)                     :: debut, lafin
101    REAL, INTENT(IN)                        :: dtime
102    REAL, DIMENSION(klon), INTENT(IN)       :: zlev, ccanopy
103    REAL, DIMENSION(klon), INTENT(IN)       :: swnet, lwnet
104    REAL, DIMENSION(klon), INTENT(IN)       :: albedo  ! albedo for whole short-wave interval
105    REAL, DIMENSION(klon), INTENT(IN)       :: tsurf
106    REAL, DIMENSION(klon), INTENT(IN)       :: p1lay
107    REAL, DIMENSION(klon), INTENT(IN)       :: cdragh, cdragm
108    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow, precip_bs
109    REAL, DIMENSION(klon), INTENT(IN)       :: temp_air, spechum
110    REAL, DIMENSION(klon), INTENT(IN)       :: AcoefH, AcoefQ, BcoefH, BcoefQ
111    REAL, DIMENSION(klon), INTENT(IN)       :: AcoefU, AcoefV, BcoefU, BcoefV
112    REAL, DIMENSION(klon), INTENT(IN)       :: pref   ! pressure reference
113    REAL, DIMENSION(klon), INTENT(IN)       :: u1, v1, gustiness
114    REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
115    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
116    REAL, DIMENSION(klon), INTENT(IN)       :: lwdown_m  ! downwelling longwave radiation at mean surface
117                                                         ! corresponds to previous sollwdown
118    REAL, DIMENSION(klon), INTENT(IN)       :: q2m, t2m
119#ifdef ISO
120    REAL, DIMENSION(ntiso,klon), INTENT(IN)       :: xtprecip_rain, xtprecip_snow
121    REAL, DIMENSION(ntiso,klon), INTENT(IN)       :: xtspechum
122#endif
123! In/Output variables
124!****************************************************************************************
125    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
126    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
127    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
128#ifdef ISO
129    REAL, DIMENSION(niso,klon), INTENT(INOUT)    :: xtsnow, xtsol
130#endif
131
132! Output variables
133!****************************************************************************************
134    REAL, DIMENSION(klon), INTENT(OUT)       :: z0m, z0h
135!albedo SB >>>
136!    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new ! albdeo for shortwave interval 1(visible)
137!    REAL, DIMENSION(klon), INTENT(OUT)       :: alb2_new ! albedo for shortwave interval 2(near infrared)
138    REAL, DIMENSION(6), INTENT(IN) :: SFRWL
139    REAL, DIMENSION(klon,nsw), INTENT(OUT)       :: alb_dir_new,alb_dif_new
140!albedo SB <<<
141    REAL, DIMENSION(klon), INTENT(OUT)       :: evap
142    REAL, DIMENSION(klon), INTENT(OUT)       :: fluxsens, fluxlat, fluxbs
143    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
144    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
145    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l     
146    REAL, DIMENSION(klon), INTENT(OUT)       :: flux_u1, flux_v1  ! flux for U and V at first model level
147    REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: veget,lai
148    REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: height
149#ifdef ISO
150    REAL, DIMENSION(ntiso,klon), INTENT(OUT)      :: xtevap
151    REAL, DIMENSION(klon), INTENT(OUT)      :: h1
152    REAL, DIMENSION(niso,klon), INTENT(OUT)      :: xtrunoff_diag
153    REAL, DIMENSION(klon), INTENT(OUT)      :: runoff_diag
154    REAL, DIMENSION(niso,klon), INTENT(IN)        :: Rland_ice
155#endif
156
157! Local variables
158!****************************************************************************************
159    REAL, DIMENSION(klon) :: p1lay_tmp
160    REAL, DIMENSION(klon) :: pref_tmp
161    REAL, DIMENSION(klon) :: swdown     ! downwelling shortwave radiation at land surface
162    REAL, DIMENSION(klon) :: epot_air           ! potential air temperature
163    REAL, DIMENSION(klon) :: tsol_rad, emis_new ! output from interfsol not used
164    REAL, DIMENSION(klon) :: u0, v0     ! surface speed
165    REAL, DIMENSION(klon) :: precip_totsnow     ! total solid precip
166    INTEGER               :: i
167
168!albedo SB >>>
169    REAL, DIMENSION(klon)      :: alb1_new,alb2_new
170!albedo SB <<<
171
172#ifdef ISO       
173      real, parameter :: t_coup = 273.15
174      real, dimension(klon) :: fqfonte_diag
175      real, dimension(klon) :: snow_evap_diag
176      real, dimension(klon) :: fqcalving_diag
177      integer :: ixt
178#endif
179!****************************************************************************************
180!Total solid precip
181
182IF (ok_bs) THEN
183precip_totsnow(:)=precip_snow(:)+precip_bs(:)
184ELSE
185precip_totsnow(:)=precip_snow(:)
186ENDIF
187!****************************************************************************************
188#ifdef ISO
189#ifdef ISOVERIF
190!        write(*,*) 'surf_land_mod 162'
191        do i=1,knon
192          if (iso_eau.gt.0) then
193            call iso_verif_egalite_choix(precip_snow(i), &
194     &          xtprecip_snow(iso_eau,i),'surf_land_mod 129', &
195     &          errmax,errmaxrel)
196            call iso_verif_egalite_choix(qsol(i), &
197     &          xtsol(iso_eau,i),'surf_land_mod 139', &
198     &          errmax,errmaxrel)
199          endif 
200        enddo
201#endif
202#ifdef ISOVERIF
203!       write(*,*) 'surf_land 169: ok_veget=',ok_veget
204        do i=1,knon
205         do ixt=1,ntiso
206           call iso_verif_noNaN(xtprecip_snow(ixt,i),'surf_land 146')
207         enddo
208        enddo
209#endif
210#endif
211
212
213!****************************************************************************************
214! Choice between call to vegetation model (ok_veget=true) or simple calculation below
215!
216!****************************************************************************************
217   IF (ok_veget) THEN
218!****************************************************************************************
219!  Call model sechiba in model ORCHIDEE
220!
221!****************************************************************************************
222       p1lay_tmp(:)      = 0.0
223       pref_tmp(:)       = 0.0
224       p1lay_tmp(1:knon) = p1lay(1:knon)/100.
225       pref_tmp(1:knon)  = pref(1:knon)/100.
226!
227!* Calculate incoming flux for SW and LW interval: swdown
228!
229       swdown(:) = 0.0
230       DO i = 1, knon
231          swdown(i) = swnet(i)/(1-albedo(i))
232       END DO
233!
234!* Calculate potential air temperature
235!
236       epot_air(:) = 0.0
237       DO i = 1, knon
238          epot_air(i) = RCPD*temp_air(i)*(pref(i)/p1lay(i))**RKAPPA
239       END DO
240
241#ifdef ISO
242      CALL abort_physic('surf_land_mod 220','isos pas prevus dans orchidee',1)
243#endif
244       ! temporary for keeping same results using lwdown_m instead of lwdown
245       CALL surf_land_orchidee(itime, dtime, date0, knon, &
246            knindex, rlon, rlat, yrmu0, pctsrf, &
247            debut, lafin, &
248            zlev,  u1, v1, gustiness, temp_air, spechum, epot_air, ccanopy, &
249            cdragh, AcoefH, AcoefQ, BcoefH, BcoefQ, &
250            precip_rain, precip_totsnow, lwdown_m, swnet, swdown, &
251            pref_tmp, q2m, t2m, &
252            evap, fluxsens, fluxlat,  &             
253            tsol_rad, tsurf_new, alb1_new, alb2_new, &
254            emis_new, z0m, z0h, qsurf, &
255            veget, lai, height &
256!#ifdef ISO
257!            , xtprecip_rain, xtprecip_snow, xtspechum, xtevap &
258!#endif
259            )                 
260
261#ifdef ISO
262#ifdef ISOVERIF
263     write(*,*) 'surf_land 193: apres surf_land_orchidee'   
264     do i=1,knon
265        if (iso_eau.gt.0) then
266             call iso_verif_egalite_choix(xtevap(iso_eau,i),evap(i), &
267    &            'surf_land 197',errmax,errmaxrel)
268        endif !if (iso_eau.gt.0) then     
269      enddo !do i=1,knon 
270#endif
271#endif
272! 
273!* Add contribution of relief to surface roughness
274! 
275       DO i=1,knon
276          z0m(i) = MAX(1.5e-05,SQRT(z0m(i)**2 + rugoro(i)**2))
277       ENDDO
278
279    ELSE  ! not ok_veget
280!****************************************************************************************
281! No extern vegetation model choosen, call simple bucket calculations instead.
282!
283!****************************************************************************************
284#ifdef ISO
285#ifdef ISOVERIF
286!       write(*,*) 'surf_land 247'
287        call iso_verif_egalite_vect1D( &
288     &           xtsnow,snow,'surf_land_mod 207',niso,klon)
289#endif
290#endif
291
292#ifdef ISO
293        if (nudge_qsol.eq.1) then
294          call surf_land_nudge_qsol(knon,rlat,rlon,qsol,xtsol,knindex)
295        endif
296        !write(*,*) 'surf_land 258'
297#endif
298       CALL surf_land_bucket(itime, jour, knon, knindex, debut, dtime,&
299            tsurf, p1lay, cdragh, precip_rain, precip_totsnow, temp_air, &
300            spechum, AcoefH, AcoefQ, BcoefH, BcoefQ, pref, &
301            u1, v1, gustiness, rugoro, swnet, lwnet, &
302            snow, qsol, agesno, tsoil, &
303            qsurf, z0m, alb1_new, alb2_new, evap, &
304            fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l &
305#ifdef ISO
306            ,xtprecip_rain, xtprecip_snow,xtspechum, &
307            xtsnow, xtsol,xtevap,h1, &
308     &      runoff_diag, xtrunoff_diag,Rland_ice &
309#endif           
310     &       )
311        z0h(1:knon)=z0m(1:knon) ! En attendant mieux
312
313
314    ENDIF ! ok_veget
315
316        ! blowing snow not treated yet over land
317        fluxbs(:)=0.
318
319
320!****************************************************************************************
321! Calculation for all land models
322! - Flux calculation at first modele level for U and V
323!****************************************************************************************
324! Suppose zero surface speed
325    u0(:)=0.0
326    v0(:)=0.0
327    CALL calcul_flux_wind(knon, dtime, &
328         u0, v0, u1, v1, gustiness, cdragm, &
329         AcoefU, AcoefV, BcoefU, BcoefV, &
330         p1lay, temp_air, &
331         flux_u1, flux_v1)
332
333#ifdef ISO
334#ifdef ISOVERIF
335!     write(*,*) 'surf_land 237: sortie'   
336      DO i=1,knon
337        IF (iso_eau >= 0) THEN
338             call iso_verif_egalite_choix(xtsnow(iso_eau,i),snow(i), &
339    &            'surf_land 241',errmax,errmaxrel)
340        ENDIF !if (iso_eau.gt.0) then     
341      ENDDO !do i=1,knon 
342#endif
343#endif
344
345!albedo SB >>>
346     SELECT CASE(NSW)
347     CASE(2)
348       alb_dir_new(1:knon,1)=alb1_new(1:knon)
349       alb_dir_new(1:knon,2)=alb2_new(1:knon)
350     CASE(4)
351       alb_dir_new(1:knon,1)=alb1_new(1:knon)
352       alb_dir_new(1:knon,2)=alb2_new(1:knon)
353       alb_dir_new(1:knon,3)=alb2_new(1:knon)
354       alb_dir_new(1:knon,4)=alb2_new(1:knon)
355     CASE(6)
356       alb_dir_new(1:knon,1)=alb1_new(1:knon)
357       alb_dir_new(1:knon,2)=alb1_new(1:knon)
358       alb_dir_new(1:knon,3)=alb1_new(1:knon)
359       alb_dir_new(1:knon,4)=alb2_new(1:knon)
360       alb_dir_new(1:knon,5)=alb2_new(1:knon)
361       alb_dir_new(1:knon,6)=alb2_new(1:knon)
362     END SELECT
363
364     alb_dif_new=alb_dir_new
365!albedo SB <<<
366   
367  END SUBROUTINE surf_land
368
369
370#ifdef ISO
371  SUBROUTINE surf_land_nudge_qsol(knon,rlat,rlon,qsol,xtsol,knindex)
372
373    USE dimphy   
374    USE infotrac_phy, ONLY: niso
375    USE isotopes_mod, ONLY: region_nudge_qsol   
376    INTEGER, INTENT(IN)                       :: knon         
377    REAL, DIMENSION(klon), INTENT(IN)         :: rlon, rlat
378    REAL, DIMENSION(klon), INTENT(INOUT)      :: qsol
379    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex   
380    REAL, DIMENSION(niso,klon), INTENT(INOUT) :: xtsol
381    REAL :: lat_min_nudge_qsol,lat_max_nudge_qsol
382    REAL :: lon_min_nudge_qsol,lon_max_nudge_qsol
383    INTEGER :: i,ixt
384    REAL :: qsol_new
385
386    IF (region_nudge_qsol == 1) THEN
387        ! Aamzonie du Sud
388        lat_min_nudge_qsol=-15.0
389        lat_max_nudge_qsol=-5.0
390        lon_min_nudge_qsol=-70.0
391        lon_max_nudge_qsol=-50.0
392    ELSE IF (region_nudge_qsol == 2) THEN
393        ! Aamzonie du Nord
394        lat_min_nudge_qsol=-5.0
395        lat_max_nudge_qsol=5.0
396        lon_min_nudge_qsol=-70.0
397        lon_max_nudge_qsol=-50.0
398    ELSE
399        WRITE(*,*) 'surf_land 298: cas pas prevu'
400        WRITE(*,*) 'region_nudge_qsol=',region_nudge_qsol
401        stop
402    ENDIF
403
404!    write(*,*) 'surf_land 314: knon=',knon
405!    write(*,*) 'rlat=',rlat
406!    write(*,*) 'rlon=',rlon
407!    write(*,*) 'region_nudge_qsol=',region_nudge_qsol
408
409    DO i=1,knon
410      IF ((rlat(knindex(i)) >= lat_min_nudge_qsol).and. &
411  &       (rlat(knindex(i)) <= lat_max_nudge_qsol).and. &
412  &       (rlon(knindex(i)) >= lon_min_nudge_qsol).and. &
413  &       (rlon(knindex(i)) <= lon_max_nudge_qsol)) THEN
414!        write(*,*) 'surf_land 324: bon domaine: rlat,rlon,qsol=', &
415!  &             rlat(knindex(i)),rlon(knindex(i)),qsol(knindex(i))
416        qsol_new=qsol(i)
417        IF (region_nudge_qsol == 1) THEN   
418           qsol_new=max(qsol(i),50.0)   
419        ELSE IF (region_nudge_qsol == 2) THEN     
420           qsol_new=max(qsol(i),120.0)
421        ELSE !if (region_nudge_qsol.eq.1) then
422           WRITE(*,*) 'surf_land 317: cas pas prevu'
423           WRITE(*,*) 'region_nudge_qsol=',region_nudge_qsol
424           STOP
425        ENDIF !if (region_nudge_qsol.eq.1) then
426        IF (qsol(i) > 0.0) THEN
427           DO ixt=1,niso
428              xtsol(ixt,i)=xtsol(ixt,i)*qsol_new/qsol(i)
429           ENDDO
430        ELSE !IF (qsol(i) > 0.0) THEN
431           DO ixt=1,niso
432             xtsol(ixt,i)=0.0
433           ENDDO
434        ENDIF !IF (qsol(i) > 0.0) THEN
435        qsol(i)=qsol_new
436        WRITE(*,*) 'surf_land 346: qsol_new=',qsol(i)     
437     ENDIF ! if ((rlat(i).ge.lat_min_nudge_qsol).and.
438  ENDDO !DO i=1,knon
439
440  END SUBROUTINE surf_land_nudge_qsol
441#endif
442
443!
444!****************************************************************************************
445! 
446END MODULE surf_land_mod
447!
448!****************************************************************************************
449! 
Note: See TracBrowser for help on using the repository browser.