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