source: LMDZ6/branches/Ocean_skin/libf/phylmdiso/change_srf_frac_mod.F90 @ 4013

Last change on this file since 4013 was 4004, checked in by Laurent Fairhead, 3 years ago

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