source: LMDZ6/trunk/libf/phylmdiso/change_srf_frac_mod.F90 @ 5278

Last change on this file since 5278 was 5274, checked in by abarral, 25 hours ago

Replace yomcst.h by existing module
  • Property svn:keywords set to Id
File size: 7.6 KB
Line 
1!
2! $Id: change_srf_frac_mod.F90 5274 2024-10-25 13:41:23Z abarral $
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: ntiso   
42#endif
43    USE yomcst_mod_h, ONLY: RPI, RCLUM, RHPLA, RKBOL, RNAVO                   &
44          , RDAY, REA, REPSM, RSIYEA, RSIDAY, ROMEGA                  &
45          , R_ecc, R_peri, R_incl                                      &
46          , RA, RG, R1SA                                         &
47          , RSIGMA                                                     &
48          , R, RMD, RMV, RD, RV, RCPD                    &
49          , RMO3, RMCO2, RMC, RMCH4, RMN2O, RMCFC11, RMCFC12        &
50          , RCPV, RCVD, RCVV, RKAPPA, RETV, eps_w                    &
51          , RCW, RCS                                                 &
52          , RLVTT, RLSTT, RLMLT, RTT, RATM                           &
53          , RESTT, RALPW, RBETW, RGAMW, RALPS, RBETS, RGAMS            &
54          , RALPD, RBETD, RGAMD
55   
56!albedo SB >>>
57    include "clesphys.h"
58!albedo SB <<<
59
60
61
62! Input arguments
63!****************************************************************************************
64    INTEGER, INTENT(IN)                     :: itime   ! current time step
65    INTEGER, INTENT(IN)                     :: jour    ! day of the year
66    REAL,    INTENT(IN)                     :: dtime   ! length of time step (s)
67 
68! In-Output arguments
69!****************************************************************************************
70   
71    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction
72    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: evap, agesno ! sub-surface fraction
73
74    REAL, DIMENSION(klon,nbsrf+1), INTENT(INOUT) :: z0m,z0h ! sub-surface fraction
75!albedo SB >>>
76    REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT) :: alb_dir,alb_dif
77!albedo SB <<<
78#ifdef ISO
79    REAL, DIMENSION(ntiso,klon,nbsrf), INTENT(INOUT)        :: xtevap
80#endif
81
82    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf
83    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: ustar
84    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: u10m
85    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: v10m
86!jyg<
87!!    REAL, DIMENSION(klon,klev+1,nbsrf), INTENT(INOUT) :: pbl_tke
88    REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(INOUT) :: pbl_tke
89!>jyg
90
91! Loccal variables
92!****************************************************************************************
93    INTEGER                        :: i, nsrf
94    LOGICAL                        :: is_modified   ! true if pctsrf is modified at this time step
95    LOGICAL                        :: test_sum=.FALSE.
96    LOGICAL, DIMENSION(klon,nbsrf) :: new_surf
97    REAL, DIMENSION(klon,nbsrf)    :: pctsrf_old    ! fraction from previous time-step
98    REAL                           :: tmpsum
99
100    pctsrf_old(:,:) = pctsrf(:,:)
101!****************************************************************************************
102! 1)
103! For each type of ocean (force, slab, couple) receive new fractions only if it's time 
104! to modify (is_modified=true). Otherwise nothing is done (is_modified=false).   
105!****************************************************************************************
106    SELECT CASE (type_ocean)
107    CASE ('force')
108       ! Read fraction from limit.nc
109       CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
110    CASE ('slab')
111       ! Get fraction from slab module
112       CALL ocean_slab_frac(itime, dtime, jour, pctsrf, is_modified)
113    CASE ('couple')
114       ! Get fraction from the coupler
115       CALL cpl_receive_frac(itime, dtime, pctsrf, is_modified)
116    END SELECT
117
118
119!****************************************************************************************
120! 2)
121! Tests and ajustements on the new fractions :
122! - Put to zero fractions that are too small
123! - Test total fraction sum is one for each grid point
124!
125!****************************************************************************************
126    IF (is_modified) THEN
127 
128! Test and exit if a fraction is negative
129       IF (MINVAL(pctsrf(:,:)) < 0.) THEN
130          WRITE(lunout,*)'Warning! One or several fractions are negative, itime=',itime
131          WRITE(lunout,*)'at point = ',MINLOC(pctsrf(:,:))
132          WRITE(lunout,*)'value = ',MINVAL(pctsrf(:,:))
133          CALL abort_physic('change_srf_frac','Negative fraction',1)
134       END IF
135
136! Optional test on the incoming fraction
137       IF (test_sum) THEN
138          DO i= 1, klon
139             tmpsum = SUM(pctsrf(i,:))
140             IF (ABS(1. - tmpsum) > 0.05) CALL abort_physic('change_srf_frac','Total fraction not equal 1.',1)
141          END DO
142       END IF
143
144! Test for too small fractions of the sum land+landice and ocean+sea-ice
145       WHERE ((pctsrf(:,is_ter) + pctsrf(:,is_lic)) < 2*EPSFRA)
146          pctsrf(:,is_ter) = 0.
147          pctsrf(:,is_lic) = 0.
148       END WHERE
149
150       WHERE ((pctsrf(:,is_oce) + pctsrf(:,is_sic)) < 2*EPSFRA)
151          pctsrf(:,is_oce) = 0.
152          pctsrf(:,is_sic) = 0.
153       END WHERE
154
155! Normalize to force total fraction to be equal one
156       DO i= 1, klon
157          tmpsum = SUM(pctsrf(i,:))
158          DO nsrf = 1, nbsrf
159             pctsrf(i,nsrf) = pctsrf(i,nsrf) / tmpsum
160          END DO
161       END DO
162
163! Test for too small fractions at each sub-surface
164       WHERE (pctsrf(:,is_ter) < EPSFRA)
165          pctsrf(:,is_lic) = pctsrf(:,is_ter) + pctsrf(:,is_lic)
166          pctsrf(:,is_ter) = 0.
167       END WHERE
168
169       WHERE (pctsrf(:,is_lic) < EPSFRA)
170          pctsrf(:,is_ter) = pctsrf(:,is_ter) + pctsrf(:,is_lic)
171          pctsrf(:,is_lic) = 0.
172       END WHERE
173
174       WHERE (pctsrf(:,is_oce) < EPSFRA)
175          pctsrf(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
176          pctsrf(:,is_oce) = 0.
177       END WHERE
178
179       WHERE (pctsrf(:,is_sic) < EPSFRA)
180          pctsrf(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
181          pctsrf(:,is_sic) = 0.
182       END WHERE
183! Send fractions back to slab ocean if needed
184       IF (type_ocean == 'slab'.AND. version_ocean.NE.'sicINT') THEN
185           WHERE (1.-zmasq(:)>EPSFRA)
186               fsic(:)=pctsrf(:,is_sic)/(1.-zmasq(:))
187           END WHERE
188       END IF
189
190!****************************************************************************************
191! 3)
192! Initialize variables where a new fraction has appered,
193! i.e. where new sea ice has been formed
194! or where ice free ocean has appread in a grid cell
195!
196!****************************************************************************************
197
198       CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old,        &
199           evap, z0m, z0h, agesno,                                &
200           tsurf, alb_dir,alb_dif, ustar, u10m, v10m, pbl_tke &
201#ifdef ISO
202     ,xtevap  &
203#endif
204&       )
205
206
207    ELSE
208       ! No modifcation should be done
209       pctsrf(:,:) = pctsrf_old(:,:)
210
211    END IF ! is_modified
212
213  END SUBROUTINE change_srf_frac
214
215
216END MODULE change_srf_frac_mod
Note: See TracBrowser for help on using the repository browser.