source: LMDZ6/trunk/libf/phylmd/change_srf_frac_mod.F90 @ 3821

Last change on this file since 3821 was 3780, checked in by evignon, 4 years ago

Premiere comission Etienne: changements pour le 1D (forcage en Ts au dessus des continents) et inclusion drag arbres dans yamada4_num=6

  • 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: 6.8 KB
Line 
1!
2! $Id: change_srf_frac_mod.F90 3780 2020-10-22 12:50:18Z musat $
3!
4MODULE change_srf_frac_mod
5
6  IMPLICIT NONE
7
8CONTAINS
9!
10! Change Surface Fractions
11! Author J Ghattas 2008
12
13  SUBROUTINE change_srf_frac(itime, dtime, jour, &
14        pctsrf, evap, z0m, z0h, agesno,              &
15        alb_dir, alb_dif, tsurf, ustar, u10m, v10m, pbl_tke)
16   
17
18
19!
20! This subroutine is called from physiq.F at each timestep.
21! 1- For each type of ocean (force, slab, couple) receive new fractions only if
22!    it's time to modify (is_modified=true). Otherwise nothing is done (is_modified=false).   
23! If received new fraction :
24! 2- Tests and ajustements are done on the fractions
25! 3- Initialize variables where a new fraction(new or melted ice) has appered,
26!
27
28    USE dimphy
29    USE surface_data, ONLY : type_ocean,version_ocean
30    USE limit_read_mod
31    USE pbl_surface_mod, ONLY : pbl_surface_newfrac
32    USE cpl_mod, ONLY : cpl_receive_frac
33    USE ocean_slab_mod, ONLY : fsic, ocean_slab_frac
34    USE indice_sol_mod
35    USE print_control_mod, ONLY: lunout
36   
37    INCLUDE "YOMCST.h"
38!albedo SB >>>
39    include "clesphys.h"
40!albedo SB <<<
41
42
43
44! Input arguments
45!****************************************************************************************
46    INTEGER, INTENT(IN)                     :: itime   ! current time step
47    INTEGER, INTENT(IN)                     :: jour    ! day of the year
48    REAL,    INTENT(IN)                     :: dtime   ! length of time step (s)
49 
50! In-Output arguments
51!****************************************************************************************
52   
53    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction
54    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: evap, agesno ! sub-surface fraction
55    REAL, DIMENSION(klon,nbsrf+1), INTENT(INOUT) :: z0m,z0h ! sub-surface fraction
56!albedo SB >>>
57    REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT) :: alb_dir,alb_dif
58!albedo SB <<<
59
60    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf
61    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: ustar
62    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: u10m
63    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: v10m
64!jyg<
65!!    REAL, DIMENSION(klon,klev+1,nbsrf), INTENT(INOUT) :: pbl_tke
66    REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(INOUT) :: pbl_tke
67!>jyg
68
69! Loccal variables
70!****************************************************************************************
71    INTEGER                        :: i, nsrf
72    LOGICAL                        :: is_modified   ! true if pctsrf is modified at this time step
73    LOGICAL                        :: test_sum=.FALSE.
74    LOGICAL, DIMENSION(klon,nbsrf) :: new_surf
75    REAL, DIMENSION(klon,nbsrf)    :: pctsrf_old    ! fraction from previous time-step
76    REAL                           :: tmpsum
77
78    pctsrf_old(:,:) = pctsrf(:,:)
79!****************************************************************************************
80! 1)
81! For each type of ocean (force, slab, couple) receive new fractions only if it's time 
82! to modify (is_modified=true). Otherwise nothing is done (is_modified=false).   
83!****************************************************************************************
84    SELECT CASE (type_ocean)
85    CASE ('force')
86       ! Read fraction from limit.nc
87       CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
88    CASE ('slab')
89       IF (version_ocean == 'sicOBS'.OR. version_ocean == 'sicNO') THEN
90       ! Read fraction from limit.nc
91           CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
92       ELSE
93       ! Get fraction from slab module
94           CALL ocean_slab_frac(itime, dtime, jour, pctsrf, is_modified)
95       ENDIF
96    CASE ('couple')
97       ! Get fraction from the coupler
98       CALL cpl_receive_frac(itime, dtime, pctsrf, is_modified)
99    END SELECT
100
101
102!****************************************************************************************
103! 2)
104! Tests and ajustements on the new fractions :
105! - Put to zero fractions that are too small
106! - Test total fraction sum is one for each grid point
107!
108!****************************************************************************************
109    IF (is_modified) THEN
110 
111! Test and exit if a fraction is negative
112       IF (MINVAL(pctsrf(:,:)) < 0.) THEN
113          WRITE(lunout,*)'Warning! One or several fractions are negative, itime=',itime
114          WRITE(lunout,*)'at point = ',MINLOC(pctsrf(:,:))
115          WRITE(lunout,*)'value = ',MINVAL(pctsrf(:,:))
116          CALL abort_physic('change_srf_frac','Negative fraction',1)
117       END IF
118
119! Optional test on the incoming fraction
120       IF (test_sum) THEN
121          DO i= 1, klon
122             tmpsum = SUM(pctsrf(i,:))
123             IF (ABS(1. - tmpsum) > 0.05) CALL abort_physic('change_srf_frac','Total fraction not equal 1.',1)
124          END DO
125       END IF
126
127! Test for too small fractions of the sum land+landice and ocean+sea-ice
128       WHERE ((pctsrf(:,is_ter) + pctsrf(:,is_lic)) < 2*EPSFRA)
129          pctsrf(:,is_ter) = 0.
130          pctsrf(:,is_lic) = 0.
131       END WHERE
132
133       WHERE ((pctsrf(:,is_oce) + pctsrf(:,is_sic)) < 2*EPSFRA)
134          pctsrf(:,is_oce) = 0.
135          pctsrf(:,is_sic) = 0.
136       END WHERE
137
138! Normalize to force total fraction to be equal one
139       DO i= 1, klon
140          tmpsum = SUM(pctsrf(i,:))
141          DO nsrf = 1, nbsrf
142             pctsrf(i,nsrf) = pctsrf(i,nsrf) / tmpsum
143          END DO
144       END DO
145
146! Test for too small fractions at each sub-surface
147       WHERE (pctsrf(:,is_ter) < EPSFRA)
148          pctsrf(:,is_lic) = pctsrf(:,is_ter) + pctsrf(:,is_lic)
149          pctsrf(:,is_ter) = 0.
150       END WHERE
151
152       WHERE (pctsrf(:,is_lic) < EPSFRA)
153          pctsrf(:,is_ter) = pctsrf(:,is_ter) + pctsrf(:,is_lic)
154          pctsrf(:,is_lic) = 0.
155       END WHERE
156
157       WHERE (pctsrf(:,is_oce) < EPSFRA)
158          pctsrf(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
159          pctsrf(:,is_oce) = 0.
160       END WHERE
161
162       WHERE (pctsrf(:,is_sic) < EPSFRA)
163          pctsrf(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
164          pctsrf(:,is_sic) = 0.
165       END WHERE
166! Send fractions back to slab ocean if needed
167       IF (type_ocean == 'slab'.AND. version_ocean.NE.'sicINT') THEN
168           WHERE (1.-zmasq(:)>EPSFRA)
169               fsic(:)=pctsrf(:,is_sic)/(1.-zmasq(:))
170           END WHERE
171       END IF
172
173!****************************************************************************************
174! 3)
175! Initialize variables where a new fraction has appered,
176! i.e. where new sea ice has been formed
177! or where ice free ocean has appread in a grid cell
178!
179!****************************************************************************************
180
181       CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old,        &
182           evap, z0m, z0h, agesno,                                &
183           tsurf, alb_dir,alb_dif, ustar, u10m, v10m, pbl_tke)
184
185    ELSE
186       ! No modifcation should be done
187       pctsrf(:,:) = pctsrf_old(:,:)
188
189    END IF ! is_modified
190
191  END SUBROUTINE change_srf_frac
192
193
194END MODULE change_srf_frac_mod
Note: See TracBrowser for help on using the repository browser.