Head

GCC Code Coverage Report

Directory:	./		Exec	Total	Coverage
File:	phylmd/change_srf_frac_mod.F90	Lines:	24	35	68.6 %
Date:	2023-06-30 12:56:34	Branches:	106	150	70.7 %


!
! $Id: change_srf_frac_mod.F90 3780 2020-10-22 12:50:18Z evignon $
!
MODULE change_srf_frac_mod

  IMPLICIT NONE

CONTAINS
!
! Change Surface Fractions
! Author J Ghattas 2008

  SUBROUTINE change_srf_frac(itime, dtime, jour, &
        pctsrf, evap, z0m, z0h, agesno,              &
        alb_dir, alb_dif, tsurf, ustar, u10m, v10m, pbl_tke)



!
! This subroutine is called from physiq.F at each timestep.
! 1- For each type of ocean (force, slab, couple) receive new fractions only if
!    it's time to modify (is_modified=true). Otherwise nothing is done (is_modified=false).
! If received new fraction :
! 2- Tests and ajustements are done on the fractions
! 3- Initialize variables where a new fraction(new or melted ice) has appered,
!

    USE dimphy
    USE surface_data, ONLY : type_ocean,version_ocean
    USE limit_read_mod
    USE pbl_surface_mod, ONLY : pbl_surface_newfrac
    USE cpl_mod, ONLY : cpl_receive_frac
    USE ocean_slab_mod, ONLY : fsic, ocean_slab_frac
    USE indice_sol_mod
    USE print_control_mod, ONLY: lunout

    INCLUDE "YOMCST.h"
!albedo SB >>>
    include "clesphys.h"
!albedo SB <<<



! Input arguments
!****************************************************************************************
    INTEGER, INTENT(IN)                     :: itime   ! current time step
    INTEGER, INTENT(IN)                     :: jour    ! day of the year
    REAL,    INTENT(IN)                     :: dtime   ! length of time step (s)

! In-Output arguments
!****************************************************************************************

    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction
    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: evap, agesno ! sub-surface fraction
    REAL, DIMENSION(klon,nbsrf+1), INTENT(INOUT) :: z0m,z0h ! sub-surface fraction
!albedo SB >>>
    REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT) :: alb_dir,alb_dif
!albedo SB <<<

    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf
    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: ustar
    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: u10m
    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: v10m
!jyg<
!!    REAL, DIMENSION(klon,klev+1,nbsrf), INTENT(INOUT) :: pbl_tke
    REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(INOUT) :: pbl_tke
!>jyg

! Loccal variables
!****************************************************************************************
    INTEGER                        :: i, nsrf
    LOGICAL                        :: is_modified   ! true if pctsrf is modified at this time step
    LOGICAL                        :: test_sum=.FALSE.
    LOGICAL, DIMENSION(klon,nbsrf) :: new_surf
    REAL, DIMENSION(klon,nbsrf)    :: pctsrf_old    ! fraction from previous time-step
    REAL                           :: tmpsum

    pctsrf_old(:,:) = pctsrf(:,:)
!****************************************************************************************
! 1)
! For each type of ocean (force, slab, couple) receive new fractions only if it's time
! to modify (is_modified=true). Otherwise nothing is done (is_modified=false).
!****************************************************************************************
    SELECT CASE (type_ocean)
    CASE ('force')
       ! Read fraction from limit.nc
       CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
    CASE ('slab')
       IF (version_ocean == 'sicOBS'.OR. version_ocean == 'sicNO') THEN
       ! Read fraction from limit.nc
           CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
       ELSE
       ! Get fraction from slab module
           CALL ocean_slab_frac(itime, dtime, jour, pctsrf, is_modified)
       ENDIF
    CASE ('couple')
       ! Get fraction from the coupler
       CALL cpl_receive_frac(itime, dtime, pctsrf, is_modified)
    END SELECT


!****************************************************************************************
! 2)
! Tests and ajustements on the new fractions :
! - Put to zero fractions that are too small
! - Test total fraction sum is one for each grid point
!
!****************************************************************************************
    IF (is_modified) THEN

! Test and exit if a fraction is negative
       IF (MINVAL(pctsrf(:,:)) < 0.) THEN
          WRITE(lunout,*)'Warning! One or several fractions are negative, itime=',itime
          WRITE(lunout,*)'at point = ',MINLOC(pctsrf(:,:))
          WRITE(lunout,*)'value = ',MINVAL(pctsrf(:,:))
          CALL abort_physic('change_srf_frac','Negative fraction',1)
       END IF

! Optional test on the incoming fraction
       IF (test_sum) THEN
          DO i= 1, klon
             tmpsum = SUM(pctsrf(i,:))
             IF (ABS(1. - tmpsum) > 0.05) CALL abort_physic('change_srf_frac','Total fraction not equal 1.',1)
          END DO
       END IF

! Test for too small fractions of the sum land+landice and ocean+sea-ice
       WHERE ((pctsrf(:,is_ter) + pctsrf(:,is_lic)) < 2*EPSFRA)
          pctsrf(:,is_ter) = 0.
          pctsrf(:,is_lic) = 0.
       END WHERE

       WHERE ((pctsrf(:,is_oce) + pctsrf(:,is_sic)) < 2*EPSFRA)
          pctsrf(:,is_oce) = 0.
          pctsrf(:,is_sic) = 0.
       END WHERE

! Normalize to force total fraction to be equal one
       DO i= 1, klon
          tmpsum = SUM(pctsrf(i,:))
          DO nsrf = 1, nbsrf
             pctsrf(i,nsrf) = pctsrf(i,nsrf) / tmpsum
          END DO
       END DO

! Test for too small fractions at each sub-surface
       WHERE (pctsrf(:,is_ter) < EPSFRA)
          pctsrf(:,is_lic) = pctsrf(:,is_ter) + pctsrf(:,is_lic)
          pctsrf(:,is_ter) = 0.
       END WHERE

       WHERE (pctsrf(:,is_lic) < EPSFRA)
          pctsrf(:,is_ter) = pctsrf(:,is_ter) + pctsrf(:,is_lic)
          pctsrf(:,is_lic) = 0.
       END WHERE

       WHERE (pctsrf(:,is_oce) < EPSFRA)
          pctsrf(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
          pctsrf(:,is_oce) = 0.
       END WHERE

       WHERE (pctsrf(:,is_sic) < EPSFRA)
          pctsrf(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
          pctsrf(:,is_sic) = 0.
       END WHERE
! Send fractions back to slab ocean if needed
       IF (type_ocean == 'slab'.AND. version_ocean.NE.'sicINT') THEN
           WHERE (1.-zmasq(:)>EPSFRA)
               fsic(:)=pctsrf(:,is_sic)/(1.-zmasq(:))
           END WHERE
       END IF

!****************************************************************************************
! 3)
! Initialize variables where a new fraction has appered,
! i.e. where new sea ice has been formed
! or where ice free ocean has appread in a grid cell
!
!****************************************************************************************

       CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old,        &
           evap, z0m, z0h, agesno,                                &
           tsurf, alb_dir,alb_dif, ustar, u10m, v10m, pbl_tke)

    ELSE
       ! No modifcation should be done
       pctsrf(:,:) = pctsrf_old(:,:)

    END IF ! is_modified

  END SUBROUTINE change_srf_frac


END MODULE change_srf_frac_mod


Generated by: GCOVR (Version 4.2)

Line	Branch	Exec	Source
1			!
2			! $Id: change_srf_frac_mod.F90 3780 2020-10-22 12:50:18Z evignon $
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		288	SUBROUTINE change_srf_frac(itime, dtime, jour, &
14		288	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 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 print_control_mod, ONLY: lunout
36
37			INCLUDE "YOMCST.h"
38			!albedo SB >>>
39			include "clesphys.h"
40			!albedo SB <<<
41
42
43
44			! Input arguments
45			!****************************************************************************************
46			INTEGER, INTENT(IN) :: itime ! current time step
47			INTEGER, INTENT(IN) :: jour ! day of the year
48			REAL, INTENT(IN) :: dtime ! length of time step (s)
49
50			! In-Output arguments
51			!****************************************************************************************
52
53			REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction
54			REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: evap, agesno ! sub-surface fraction
55			REAL, DIMENSION(klon,nbsrf+1), INTENT(INOUT) :: z0m,z0h ! sub-surface fraction
56			!albedo SB >>>
57			REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT) :: alb_dir,alb_dif
58			!albedo SB <<<
59
60			REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf
61			REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: ustar
62			REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: u10m
63			REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: v10m
64			!jyg<
65			!! REAL, DIMENSION(klon,klev+1,nbsrf), INTENT(INOUT) :: pbl_tke
66			REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(INOUT) :: pbl_tke
67			!>jyg
68
69			! Loccal variables
70			!****************************************************************************************
71			INTEGER :: i, nsrf
72			LOGICAL :: is_modified ! true if pctsrf is modified at this time step
73			LOGICAL :: test_sum=.FALSE.
74			LOGICAL, DIMENSION(klon,nbsrf) :: new_surf
75		288	REAL, DIMENSION(klon,nbsrf) :: pctsrf_old ! fraction from previous time-step
76			REAL :: tmpsum
77
78	✓✓✓✓	1146528	pctsrf_old(:,:) = pctsrf(:,:)
79			!****************************************************************************************
80			! 1)
81			! For each type of ocean (force, slab, couple) receive new fractions only if it's time
82			! to modify (is_modified=true). Otherwise nothing is done (is_modified=false).
83			!****************************************************************************************
84		288	SELECT CASE (type_ocean)
85			CASE ('force')
86			! Read fraction from limit.nc
87		288	CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
88			CASE ('slab')
89			IF (version_ocean == 'sicOBS'.OR. version_ocean == 'sicNO') THEN
90			! Read fraction from limit.nc
91			CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
92			ELSE
93			! Get fraction from slab module
94			CALL ocean_slab_frac(itime, dtime, jour, pctsrf, is_modified)
95			ENDIF
96			CASE ('couple')
97			! Get fraction from the coupler
98	✓✗✗✗	288	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	✓✓	288	IF (is_modified) THEN
110
111			! Test and exit if a fraction is negative
112	✓✓✓✓ ✓✓✗✓ ✓✗✗✓ ✗✗✗✓	23886	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	✗✓	6	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	✓✓✓✓ ✓✓✓✓ ✓✓	17898	WHERE ((pctsrf(:,is_ter) + pctsrf(:,is_lic)) < 2*EPSFRA)
129			pctsrf(:,is_ter) = 0.
130			pctsrf(:,is_lic) = 0.
131			END WHERE
132
133	✓✓✓✓ ✓✓✓✓ ✓✓	17898	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	✓✓	5970	DO i= 1, klon
140	✓✓	29820	tmpsum = SUM(pctsrf(i,:))
141	✓✓	29826	DO nsrf = 1, nbsrf
142		29820	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	✓✓✓✗ ✓✓✓✓ ✓✓✓✓ ✓✓✓✓	23862	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	✓✓✓✓ ✓✓✓✓ ✓✓✓✓ ✓✓	23862	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	✓✓✓✓ ✓✓✓✓ ✓✓✓✓ ✓✓	23862	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	✓✓✓✓ ✓✓✓✓ ✓✓✓✓ ✓✓	23862	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	✗✓✗✗	6	IF (type_ocean == 'slab'.AND. version_ocean.NE.'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		6	tsurf, alb_dir,alb_dif, ustar, u10m, v10m, pbl_tke)
184
185			ELSE
186			! No modifcation should be done
187	✓✓✓✓	1122642	pctsrf(:,:) = pctsrf_old(:,:)
188
189			END IF ! is_modified
190
191		288	END SUBROUTINE change_srf_frac
192
193
194			END MODULE change_srf_frac_mod