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

Last change on this file since 5112 was 5112, checked in by abarral, 4 months ago

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