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