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

Last change on this file since 5426 was 5305, checked in by abarral, 7 weeks ago

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