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