source: LMDZ6/branches/Amaury_dev/libf/phylmdiso/change_srf_frac_mod.F90 @ 5137

Last change on this file since 5137 was 5137, checked in by abarral, 3 months ago

Put gradsdef.h, tracstoke.h, clesphys.h into modules
  • Property svn:keywords set to Id
File size: 6.9 KB
Line 
1
2! $Id: change_srf_frac_mod.F90 5137 2024-07-28 20:25:12Z abarral $
3
4MODULE change_srf_frac_mod
5USE lmdz_abort_physic, ONLY: abort_physic
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! This SUBROUTINE is called from physiq.F at each timestep.
22! 1- For each type of ocean (force, slab, couple) receive new fractions only if
23!    it's time to modify (is_modified=true). Otherwise nothing is done (is_modified=false).   
24! If received new fraction :
25! 2- Tests and ajustements are done on the fractions
26! 3- Initialize variables where a new fraction(new or melted ice) has appered,
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 lmdz_print_control, ONLY: lunout
36#ifdef ISO
37  USE infotrac_phy, ONLY: ntiso   
38#endif
39  USE lmdz_clesphys ! albedo SB
40   
41    INCLUDE "YOMCST.h"
42
43
44
45! Input arguments
46!****************************************************************************************
47    INTEGER, INTENT(IN)                     :: itime   ! current time step
48    INTEGER, INTENT(IN)                     :: jour    ! day of the year
49    REAL,    INTENT(IN)                     :: dtime   ! length of time step (s)
50 
51! In-Output arguments
52!****************************************************************************************
53   
54    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction
55    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: evap, agesno ! sub-surface fraction
56
57    REAL, DIMENSION(klon,nbsrf+1), INTENT(INOUT) :: z0m,z0h ! sub-surface fraction
58!albedo SB >>>
59    REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT) :: alb_dir,alb_dif
60!albedo SB <<<
61#ifdef ISO
62    REAL, DIMENSION(ntiso,klon,nbsrf), INTENT(INOUT)        :: xtevap
63#endif
64
65    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf
66    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: ustar
67    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: u10m
68    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: v10m
69!jyg<
70!!    REAL, DIMENSION(klon,klev+1,nbsrf), INTENT(INOUT) :: pbl_tke
71    REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(INOUT) :: pbl_tke
72!>jyg
73
74! Loccal variables
75!****************************************************************************************
76    INTEGER                        :: i, nsrf
77    LOGICAL                        :: is_modified   ! true if pctsrf is modified at this time step
78    LOGICAL                        :: test_sum=.FALSE.
79    LOGICAL, DIMENSION(klon,nbsrf) :: new_surf
80    REAL, DIMENSION(klon,nbsrf)    :: pctsrf_old    ! fraction from previous time-step
81    REAL                           :: tmpsum
82
83    pctsrf_old(:,:) = pctsrf(:,:)
84!****************************************************************************************
85! 1)
86! For each type of ocean (force, slab, couple) receive new fractions only if it's time 
87! to modify (is_modified=true). Otherwise nothing is done (is_modified=false).   
88!****************************************************************************************
89    SELECT CASE (type_ocean)
90    CASE ('force')
91       ! Read fraction from limit.nc
92       CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
93    CASE ('slab')
94       ! Get fraction from slab module
95       CALL ocean_slab_frac(itime, dtime, jour, pctsrf, is_modified)
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/='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#ifdef ISO
185     ,xtevap  &
186#endif
187&       )
188
189
190    ELSE
191       ! No modifcation should be done
192       pctsrf(:,:) = pctsrf_old(:,:)
193
194    END IF ! is_modified
195
196  END SUBROUTINE change_srf_frac
197
198
199END MODULE change_srf_frac_mod
Note: See TracBrowser for help on using the repository browser.