source: LMDZ6/trunk/libf/phylmd/change_srf_frac_mod.f90 @ 5274

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

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