1 | ! |
---|
2 | ! $Id: change_srf_frac_mod.F90 4446 2023-03-01 17:22:39Z dcugnet $ |
---|
3 | ! |
---|
4 | MODULE change_srf_frac_mod |
---|
5 | |
---|
6 | IMPLICIT NONE |
---|
7 | |
---|
8 | CONTAINS |
---|
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: ntiso |
---|
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(ntiso,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 | |
---|
205 | END MODULE change_srf_frac_mod |
---|