Index: LMDZ6/trunk/libf/phylmdiso/fonte_neige_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/fonte_neige_mod.F90 (revision 5943) +++ LMDZ6/trunk/libf/phylmdiso/fonte_neige_mod.F90 (revision 5943) @@ -0,0 +1,728 @@ +! +! $Header$ +! +MODULE fonte_neige_mod +! +! This module will treat the process of snow, melting, accumulating, calving, in +! case of simplified soil model. +! +!**************************************************************************************** + USE dimphy, ONLY : klon + USE indice_sol_mod + + IMPLICIT NONE + SAVE + +! run_off_ter and run_off_lic are the runoff at the compressed grid knon for +! land and land-ice respectively +! Note: run_off_lic is used in mod_landice and therfore not private + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE :: run_off_ter + !$OMP THREADPRIVATE(run_off_ter) + REAL, ALLOCATABLE, DIMENSION(:) :: run_off_lic + !$OMP THREADPRIVATE(run_off_lic) + +! run_off_lic_0 is the runoff at land-ice a time-step earlier, on the global 1D array grid + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE :: run_off_lic_0 + !$OMP THREADPRIVATE(run_off_lic_0) + + REAL, PRIVATE :: tau_calv + !$OMP THREADPRIVATE(tau_calv) + REAL, ALLOCATABLE, DIMENSION(:,:) :: ffonte_global + !$OMP THREADPRIVATE(ffonte_global) + REAL, ALLOCATABLE, DIMENSION(:,:) :: fqfonte_global + !$OMP THREADPRIVATE(fqfonte_global) + REAL, ALLOCATABLE, DIMENSION(:,:) :: fqcalving_global + !$OMP THREADPRIVATE(fqcalving_global) + REAL, ALLOCATABLE, DIMENSION(:) :: runofflic_global + !$OMP THREADPRIVATE(runofflic_global) +#ifdef ISO + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE :: xtrun_off_ter + !$OMP THREADPRIVATE(xtrun_off_ter) + REAL, ALLOCATABLE, DIMENSION(:,:) :: xtrun_off_lic + !$OMP THREADPRIVATE(xtrun_off_lic) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE :: xtrun_off_lic_0 + !$OMP THREADPRIVATE(xtrun_off_lic_0) + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE:: fxtfonte_global + !$OMP THREADPRIVATE(fxtfonte_global) + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE:: fxtcalving_global + !$OMP THREADPRIVATE(fxtcalving_global) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE :: xtrunofflic_global + !$OMP THREADPRIVATE(xtrunofflic_global) +#endif + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE fonte_neige_init(restart_runoff) + +! This subroutine allocates and initialize variables in the module. +! The variable run_off_lic_0 is initialized to the field read from +! restart file. The other variables are initialized to zero. +! +!**************************************************************************************** +! Input argument + REAL, DIMENSION(klon), INTENT(IN) :: restart_runoff + +! Local variables + INTEGER :: error + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'fonte_neige_init' + + +!**************************************************************************************** +! Allocate run-off at landice and initilize with field read from restart +! +!**************************************************************************************** + + ALLOCATE(run_off_lic_0(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation run_off_lic' + CALL abort_physic(modname,abort_message,1) + ENDIF + run_off_lic_0(:) = restart_runoff(:) + +!**************************************************************************************** +! Allocate other variables and initilize to zero +! +!**************************************************************************************** + ALLOCATE(run_off_ter(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation run_off_ter' + CALL abort_physic(modname,abort_message,1) + ENDIF + run_off_ter(:) = 0. + + ALLOCATE(run_off_lic(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation run_off_lic' + CALL abort_physic(modname,abort_message,1) + ENDIF + run_off_lic(:) = 0. + + ALLOCATE(ffonte_global(klon,nbsrf)) + IF (error /= 0) THEN + abort_message='Pb allocation ffonte_global' + CALL abort_physic(modname,abort_message,1) + ENDIF + ffonte_global(:,:) = 0.0 + + ALLOCATE(fqfonte_global(klon,nbsrf)) + IF (error /= 0) THEN + abort_message='Pb allocation fqfonte_global' + CALL abort_physic(modname,abort_message,1) + ENDIF + fqfonte_global(:,:) = 0.0 + + ALLOCATE(fqcalving_global(klon,nbsrf)) + IF (error /= 0) THEN + abort_message='Pb allocation fqcalving_global' + CALL abort_physic(modname,abort_message,1) + ENDIF + fqcalving_global(:,:) = 0.0 + + ALLOCATE(runofflic_global(klon)) + IF (error /= 0) THEN + abort_message='Pb allocation runofflic_global' + CALL abort_physic(modname,abort_message,1) + ENDIF + runofflic_global(:) = 0.0 + +!**************************************************************************************** +! Read tau_calv +! +!**************************************************************************************** + CALL conf_interface(tau_calv) + + + END SUBROUTINE fonte_neige_init + +#ifdef ISO + SUBROUTINE fonte_neige_init_iso(xtrestart_runoff) + +! This subroutine allocates and initialize variables in the module. +! The variable run_off_lic_0 is initialized to the field read from +! restart file. The other variables are initialized to zero. + + USE infotrac_phy, ONLY: niso +#ifdef ISOVERIF + USE isotopes_mod, ONLY: iso_eau,iso_HDO + USE isotopes_verif_mod +#endif +! +!**************************************************************************************** +! Input argument + REAL, DIMENSION(niso,klon), INTENT(IN) :: xtrestart_runoff + +! Local variables + INTEGER :: error + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'fonte_neige_init' + INTEGER :: i + + +!**************************************************************************************** +! Allocate run-off at landice and initilize with field read from restart +! +!**************************************************************************************** + + ALLOCATE(xtrun_off_lic_0(niso,klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation run_off_lic' + CALL abort_physic(modname,abort_message,1) + ENDIF + + xtrun_off_lic_0(:,:) = xtrestart_runoff(:,:) + +#ifdef ISOVERIF + IF (iso_eau > 0) THEN + CALL iso_verif_egalite_vect1D( & + & xtrun_off_lic_0,run_off_lic_0,'fonte_neige 100', & + & niso,klon) + ENDIF !IF (iso_eau > 0) THEN +#endif + +!**************************************************************************************** +! Allocate other variables and initilize to zero +! +!**************************************************************************************** + + ALLOCATE(xtrun_off_ter(niso,klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation xtrun_off_ter' + CALL abort_physic(modname,abort_message,1) + ENDIF + xtrun_off_ter(:,:) = 0. + + ALLOCATE(xtrun_off_lic(niso,klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation xtrun_off_lic' + CALL abort_physic(modname,abort_message,1) + ENDIF + xtrun_off_lic(:,:) = 0. + + ALLOCATE(fxtfonte_global(niso,klon,nbsrf)) + IF (error /= 0) THEN + abort_message='Pb allocation fxtfonte_global' + CALL abort_physic(modname,abort_message,1) + ENDIF + fxtfonte_global(:,:,:) = 0.0 + + ALLOCATE(fxtcalving_global(niso,klon,nbsrf)) + IF (error /= 0) THEN + abort_message='Pb allocation fxtcalving_global' + CALL abort_physic(modname,abort_message,1) + ENDIF + fxtcalving_global(:,:,:) = 0.0 + + ALLOCATE(xtrunofflic_global(niso,klon)) + IF (error /= 0) THEN + abort_message='Pb allocation xtrunofflic_global' + CALL abort_physic(modname,abort_message,1) + ENDIF + xtrunofflic_global(:,:) = 0.0 + + END SUBROUTINE fonte_neige_init_iso +#endif + +! +!**************************************************************************************** +! + SUBROUTINE fonte_neige( knon, nisurf, knindex, dtime, & + tsurf, precip_rain, precip_snow, & + snow, qsol, tsurf_new, evap, ice_sub & +#ifdef ISO + & ,fq_fonte_diag,fqfonte_diag,snow_evap_diag,fqcalving_diag & + & ,max_eau_sol_diag,runoff_diag,run_off_lic_diag,coeff_rel_diag & +#endif + & ) + + USE indice_sol_mod +#ifdef ISO + USE infotrac_phy, ONLY: niso + !use isotopes_mod, ONLY: ridicule_snow,iso_eau,iso_HDO +#ifdef ISOVERIF + USE isotopes_verif_mod +#endif +#endif +USE yoethf_mod_h + USE clesphys_mod_h + USE yomcst_mod_h + +! Routine de traitement de la fonte de la neige dans le cas du traitement +! de sol simplifie! +! LF 03/2001 +! input: +! knon nombre de points a traiter +! nisurf surface a traiter +! knindex index des mailles valables pour surface a traiter +! dtime +! tsurf temperature de surface +! precip_rain precipitations liquides +! precip_snow precipitations solides +! +! input/output: +! snow champs hauteur de neige +! qsol hauteur d'eau contenu dans le sol +! tsurf_new temperature au sol +! evap +! + INCLUDE "FCTTRE.h" + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + INTEGER, INTENT(IN) :: nisurf + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL , INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain + REAL, DIMENSION(klon), INTENT(IN) :: precip_snow + + ! Input/Output variables +!**************************************************************************************** + + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + REAL, DIMENSION(klon), INTENT(INOUT) :: qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(INOUT) :: evap + + + REAL, DIMENSION(klon), INTENT(OUT) :: ice_sub +#ifdef ISO + ! sortie de quelques diagnostiques + REAL, DIMENSION(klon), INTENT(OUT) :: fq_fonte_diag + REAL, DIMENSION(klon), INTENT(OUT) :: fqfonte_diag + REAL, DIMENSION(klon), INTENT(OUT) :: snow_evap_diag + REAL, DIMENSION(klon), INTENT(OUT) :: fqcalving_diag + REAL, INTENT(OUT) :: max_eau_sol_diag + REAL, DIMENSION(klon), INTENT(OUT) :: runoff_diag + REAL, DIMENSION(klon), INTENT(OUT) :: run_off_lic_diag + REAL, INTENT(OUT) :: coeff_rel_diag +#endif + + +! Local variables +!**************************************************************************************** + + INTEGER :: i, j + REAL :: fq_fonte + REAL :: coeff_rel + REAL, PARAMETER :: snow_max=3000. + REAL, PARAMETER :: max_eau_sol = 150.0 +!! PB temporaire en attendant mieux pour le modele de neige +! REAL, parameter :: chasno = RLMLT/(2.3867E+06*0.15) + REAL, PARAMETER :: chasno = 3.334E+05/(2.3867E+06*0.15) +!IM cf JLD/ GKtest + REAL, PARAMETER :: chaice = 3.334E+05/(2.3867E+06*0.15) +! fin GKtest + REAL, DIMENSION(klon) :: ffonte + REAL, DIMENSION(klon) :: fqcalving, fqfonte + REAL, DIMENSION(klon) :: d_ts + REAL, DIMENSION(klon) :: bil_eau_s, snow_evap + + LOGICAL :: neige_fond + +#ifdef ISO + max_eau_sol_diag=max_eau_sol +#endif + + +!**************************************************************************************** +! Start calculation +! - Initialization +! +!**************************************************************************************** + coeff_rel = dtime/(tau_calv * rday) + + bil_eau_s(:) = 0. + +!**************************************************************************************** +! - Increment snow due to precipitation and evaporation +! - Calculate the water balance due to precipitation and evaporation (bil_eau_s) +! +!**************************************************************************************** + WHERE (precip_snow > 0.) + snow = snow + (precip_snow * dtime) + END WHERE + + snow_evap = 0. + ice_sub(:) = 0. + + IF (.NOT. ok_lic_cond) THEN +!---only positive evaporation has an impact on snow +!---note that this could create a bit of water +!---this was the default until CMIP6 + WHERE (evap > 0. ) + snow_evap = MIN (snow / dtime, evap) !---one cannot evaporate more than the amount of snow + snow = snow - snow_evap * dtime !---snow that remains on the ground + snow = MAX(0.0, snow) !---just in case + END WHERE + ELSE +!--now considers both positive and negative evaporation in the budget of snow + snow_evap = MIN (snow / dtime, evap) !---one cannot evaporate more than the amount of snow + snow = snow - snow_evap * dtime !---snow that remains or deposits on the ground + snow = MAX(0.0, snow) !---just in case + ENDIF + + bil_eau_s(:) = (precip_rain(:) * dtime) - (evap(:) - snow_evap(:)) * dtime + + IF (nisurf==is_lic) THEN + DO i=1,knon + ice_sub(i)=evap(i)-snow_evap(i) + ENDDO + ENDIF + +#ifdef ISO + snow_evap_diag(:) = snow_evap(:) + coeff_rel_diag = coeff_rel +#endif + + + +!**************************************************************************************** +! - Calculate melting snow +! - Calculate calving and decrement snow, if there are to much snow +! - Update temperature at surface +! +!**************************************************************************************** + + ffonte(:) = 0.0 + fqcalving(:) = 0.0 + fqfonte(:) = 0.0 + + DO i = 1, knon + ! Y'a-t-il fonte de neige? + neige_fond = (snow(i)>epsfra .OR. nisurf==is_sic .OR. nisurf==is_lic) .AND. tsurf_new(i)>=RTT + IF (neige_fond) THEN + fq_fonte = MIN( MAX((tsurf_new(i)-RTT )/chasno,0.0),snow(i)) + ffonte(i) = fq_fonte * RLMLT/dtime + fqfonte(i) = fq_fonte/dtime + snow(i) = MAX(0., snow(i) - fq_fonte) + bil_eau_s(i) = bil_eau_s(i) + fq_fonte + tsurf_new(i) = tsurf_new(i) - fq_fonte * chasno +#ifdef ISO + fq_fonte_diag(i) = fq_fonte +#endif + + +!IM cf JLD OK +!IM cf JLD/ GKtest fonte aussi pour la glace + IF (nisurf == is_sic .OR. nisurf == is_lic ) THEN + fq_fonte = MAX((tsurf_new(i)-RTT )/chaice,0.0) + ffonte(i) = ffonte(i) + fq_fonte * RLMLT/dtime + IF ( ok_lic_melt ) THEN + fqfonte(i) = fqfonte(i) + fq_fonte/dtime + bil_eau_s(i) = bil_eau_s(i) + fq_fonte + ENDIF + tsurf_new(i) = RTT + ENDIF + d_ts(i) = tsurf_new(i) - tsurf(i) + ENDIF + + ! s'il y a une hauteur trop importante de neige, elle est ecretee + fqcalving(i) = MAX(0., snow(i) - snow_max)/dtime + snow(i)=MIN(snow(i),snow_max) + ENDDO +#ifdef ISO + DO i = 1, knon + fqcalving_diag(i) = fqcalving(i) + fqfonte_diag(i) = fqfonte(i) + ENDDO !DO i = 1, knon +#endif + + + IF (nisurf == is_ter) THEN + DO i = 1, knon + qsol(i) = qsol(i) + bil_eau_s(i) + run_off_ter(i) = run_off_ter(i) + MAX(qsol(i) - max_eau_sol, 0.0) +#ifdef ISO + runoff_diag(i) = MAX(qsol(i) - max_eau_sol, 0.0) +#endif + qsol(i) = MIN(qsol(i), max_eau_sol) + ENDDO + ELSE IF (nisurf == is_lic) THEN + DO i = 1, knon + j = knindex(i) + !--temporal filtering + run_off_lic(i) = coeff_rel*fqcalving(i) + (1.-coeff_rel)*run_off_lic_0(j) + run_off_lic_0(j) = run_off_lic(i) + !--add melting snow and liquid precip to runoff of ice cap + run_off_lic(i) = run_off_lic(i) + fqfonte(i) + precip_rain(i) + ENDDO + ENDIF + +#ifdef ISO + DO i = 1, klon + run_off_lic_diag(i) = run_off_lic(i) + ENDDO ! DO i = 1, knon +#endif + +!**************************************************************************************** +! Save ffonte, fqfonte and fqcalving in global arrays for each +! sub-surface separately +! +!**************************************************************************************** + DO i = 1, knon + ffonte_global(knindex(i),nisurf) = ffonte(i) + fqfonte_global(knindex(i),nisurf) = fqfonte(i) + fqcalving_global(knindex(i),nisurf) = fqcalving(i) + ENDDO + + IF (nisurf == is_lic) THEN + DO i = 1, knon + runofflic_global(knindex(i)) = run_off_lic(i) + ENDDO + ENDIF + + END SUBROUTINE fonte_neige +! +!**************************************************************************************** +! + SUBROUTINE fonte_neige_final(restart_runoff & +#ifdef ISO + & ,xtrestart_runoff & +#endif + & ) +! +! This subroutine returns run_off_lic_0 for later writing to restart file. +! +#ifdef ISO + USE infotrac_phy, ONLY: niso +#ifdef ISOVERIF + USE isotopes_mod, ONLY: iso_eau + USE isotopes_verif_mod +#endif +#endif +! +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: restart_runoff +#ifdef ISO + REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtrestart_runoff +#ifdef ISOVERIF + INTEGER :: i +#endif +#endif + + + +!**************************************************************************************** +! Set the output variables + restart_runoff(:) = run_off_lic_0(:) +#ifdef ISO + xtrestart_runoff(:,:) = xtrun_off_lic_0(:,:) +#ifdef ISOVERIF + IF (iso_eau > 0) THEN + DO i=1,klon + IF (iso_verif_egalite_nostop(run_off_lic_0(i) & + & ,xtrun_off_lic_0(iso_eau,i) & + & ,'fonte_neige 413') & + & == 1) then + WRITE(*,*) 'i=',i + STOP + ENDIF + ENDDO !DO i=1,klon + ENDIF !IF (iso_eau > 0) then +#endif +#endif + + + +! Deallocation of all varaibles in the module +! DEALLOCATE(run_off_lic_0, run_off_ter, run_off_lic, ffonte_global, & +! fqfonte_global, fqcalving_global) + + IF (ALLOCATED(run_off_lic_0)) DEALLOCATE(run_off_lic_0) + IF (ALLOCATED(run_off_ter)) DEALLOCATE(run_off_ter) + IF (ALLOCATED(run_off_lic)) DEALLOCATE(run_off_lic) + IF (ALLOCATED(ffonte_global)) DEALLOCATE(ffonte_global) + IF (ALLOCATED(fqfonte_global)) DEALLOCATE(fqfonte_global) + IF (ALLOCATED(fqcalving_global)) DEALLOCATE(fqcalving_global) + IF (ALLOCATED(runofflic_global)) DEALLOCATE(runofflic_global) +#ifdef ISO + IF (ALLOCATED(xtrun_off_lic_0)) DEALLOCATE(xtrun_off_lic_0) + IF (ALLOCATED(xtrun_off_ter)) DEALLOCATE(xtrun_off_ter) + IF (ALLOCATED(xtrun_off_lic)) DEALLOCATE(xtrun_off_lic) + IF (ALLOCATED(fxtfonte_global)) DEALLOCATE(fxtfonte_global) + IF (ALLOCATED(fxtcalving_global)) DEALLOCATE(fxtcalving_global) + IF (ALLOCATED(xtrunofflic_global)) DEALLOCATE(xtrunofflic_global) +#endif + + + END SUBROUTINE fonte_neige_final +! +!**************************************************************************************** +! + SUBROUTINE fonte_neige_get_vars(pctsrf, fqcalving_out, & + fqfonte_out, ffonte_out, run_off_lic_out & +#ifdef ISO + & ,fxtcalving_out, fxtfonte_out,xtrun_off_lic_out & +#endif + & ) + + +! Cumulate ffonte, fqfonte and fqcalving respectively for +! all type of surfaces according to their fraction. +! +! This routine is called from physiq.F before histwrite. +!**************************************************************************************** + + USE indice_sol_mod +#ifdef ISO + USE infotrac_phy, ONLY: niso +#endif + + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + + REAL, DIMENSION(klon), INTENT(OUT) :: fqcalving_out + REAL, DIMENSION(klon), INTENT(OUT) :: fqfonte_out + REAL, DIMENSION(klon), INTENT(OUT) :: ffonte_out + REAL, DIMENSION(klon), INTENT(OUT) :: run_off_lic_out + +#ifdef ISO + REAL, DIMENSION(niso,klon), INTENT(OUT) :: fxtcalving_out + REAL, DIMENSION(niso,klon), INTENT(OUT) :: fxtfonte_out + REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtrun_off_lic_out + INTEGER :: i,ixt +#endif + + INTEGER :: nisurf +!**************************************************************************************** + + ffonte_out(:) = 0.0 + fqfonte_out(:) = 0.0 + fqcalving_out(:) = 0.0 +#ifdef ISO + fxtfonte_out(:,:) = 0.0 + fxtcalving_out(:,:) = 0.0 +#endif + + DO nisurf = 1, nbsrf + ffonte_out(:) = ffonte_out(:) + ffonte_global(:,nisurf)*pctsrf(:,nisurf) + fqfonte_out(:) = fqfonte_out(:) + fqfonte_global(:,nisurf)*pctsrf(:,nisurf) + fqcalving_out(:) = fqcalving_out(:) + fqcalving_global(:,nisurf)*pctsrf(:,nisurf) + ENDDO + + run_off_lic_out(:)=runofflic_global(:) + +#ifdef ISO + DO nisurf = 1, nbsrf + DO i=1,klon + DO ixt=1,niso + fxtfonte_out(ixt,i) = fxtfonte_out(ixt,i) + fxtfonte_global(ixt,i,nisurf)*pctsrf(i,nisurf) + fxtcalving_out(ixt,i) = fxtcalving_out(ixt,i) + fxtcalving_global(ixt,i,nisurf)*pctsrf(i,nisurf) + ENDDO !DO ixt=1,niso + ENDDO !DO i=1,klon + ENDDO !DO nisurf = 1, nbsrf + xtrun_off_lic_out(:,:) = xtrunofflic_global(:,:) +#endif + + END SUBROUTINE fonte_neige_get_vars +! +!**************************************************************************************** +! +!#ifdef ISO +! subroutine fonte_neige_export_xtrun_off_lic_0(knon,xtrun_off_lic_0_diag) +! use infotrac_phy, ONLY: niso +! +! ! inputs +! INTEGER, INTENT(IN) :: knon +! real, INTENT(IN), DIMENSION(niso,klon) :: xtrun_off_lic_0_diag +! +! xtrun_off_lic_0(:,:)=xtrun_off_lic_0_diag(:,:) +! +! end subroutine fonte_neige_export_xtrun_off_lic_0 +!#endif + +#ifdef ISO + SUBROUTINE gestion_neige_besoin_varglob_fonte_neige(klon,knon, & + & xtprecip_snow,xtprecip_rain, & + & fxtfonte_neige,fxtcalving, & + & knindex,nisurf,run_off_lic_diag,coeff_rel_diag) + + ! dans cette routine, on a besoin des variables globales de + ! fonte_neige_mod. Il faut donc la mettre dans fonte_neige_mod + ! le reste de gestion_neige est dans isotopes_routines_mod car sinon pb + ! de dépendance circulaire. + + USE infotrac_phy, ONLY: ntiso,niso + USE isotopes_mod, ONLY: iso_eau + USE indice_sol_mod +#ifdef ISOVERIF + USE isotopes_verif_mod +#endif + IMPLICIT NONE + + ! inputs + INTEGER, INTENT(IN) :: klon,knon + REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtprecip_snow, xtprecip_rain + REAL, DIMENSION(niso,klon), INTENT(IN) :: fxtfonte_neige,fxtcalving + INTEGER, INTENT(IN) :: nisurf + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, DIMENSION(klon), INTENT(IN) :: run_off_lic_diag + REAL, INTENT(IN) :: coeff_rel_diag + + ! locals + INTEGER :: i,ixt,j + +#ifdef ISOVERIF + IF (nisurf == is_lic) THEN + IF (iso_eau > 0) THEN + DO i = 1, knon + j = knindex(i) + CALL iso_verif_egalite(xtrun_off_lic_0(iso_eau,j), & + & run_off_lic_0(j),'gestion_neige_besoin_varglob_fonte_neige 625') + ENDDO + ENDIF + ENDIF +#endif + +! calcul de run_off_lic + + IF (nisurf == is_lic) THEN +! coeff_rel = dtime/(tau_calv * rday) + + DO i = 1, knon + j = knindex(i) + DO ixt = 1, niso + xtrun_off_lic(ixt,i) = (coeff_rel_diag * fxtcalving(ixt,i)) & + & +(1. - coeff_rel_diag) * xtrun_off_lic_0(ixt,j) + xtrun_off_lic_0(ixt,j) = xtrun_off_lic(ixt,i) + xtrun_off_lic(ixt,i) = xtrun_off_lic(ixt,i) + fxtfonte_neige(ixt,i) + xtprecip_rain(ixt,i) + ENDDO !DO ixt=1,niso +#ifdef ISOVERIF + IF (iso_eau > 0) THEN + IF (iso_verif_egalite_choix_nostop(xtrun_off_lic(iso_eau,i), & + & run_off_lic_diag(i),'gestion_neige_besoin_varglob_fonte_neige 1201a', & + & errmax,errmaxrel) == 1) THEN + WRITE(*,*) 'i,j=',i,j + WRITE(*,*) 'coeff_rel_diag=',coeff_rel_diag + STOP + ENDIF + ENDIF +#endif + ENDDO + ENDIF !IF (nisurf == is_lic) THEN + +! Save ffonte, fqfonte and fqcalving in global arrays for each +! sub-surface separately + DO i = 1, knon + DO ixt = 1, niso + fxtfonte_global(ixt,knindex(i),nisurf) = fxtfonte_neige(ixt,i) + fxtcalving_global(ixt,knindex(i),nisurf) = fxtcalving(ixt,i) + ENDDO !do ixt=1,niso + ENDDO + + IF (nisurf == is_lic) THEN + DO i = 1, knon + DO ixt = 1, niso + xtrunofflic_global(ixt,knindex(i)) = xtrun_off_lic(ixt,i) + ENDDO ! DO ixt=1,niso + ENDDO + ENDIF + + END SUBROUTINE gestion_neige_besoin_varglob_fonte_neige +#endif + + +END MODULE fonte_neige_mod Index: LMDZ6/trunk/libf/phylmdiso/ocean_forced_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/ocean_forced_mod.F90 (revision 5943) +++ LMDZ6/trunk/libf/phylmdiso/ocean_forced_mod.F90 (revision 5943) @@ -0,0 +1,1057 @@ +! +! $Id: ocean_forced_mod.F90 5662 2025-05-20 14:24:41Z fairhead $ +! +MODULE ocean_forced_mod +! +! This module is used for both the sub-surfaces ocean and sea-ice for the case of a +! forced ocean, "ocean=force". +! + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE ocean_forced_noice( & + itime, dtime, jour, knon, knindex, & + p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, & + temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, gustiness, tsurf_in, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l, sens_prec_liq, rhoa, & + dthetadz300,pctsrf,Ampl & +#ifdef ISO + ,xtprecip_rain, xtprecip_snow, xtspechum,Roce,rlat, & + xtsnow,xtevap,h1 & +#endif + ) +! +! This subroutine treats the "open ocean", all grid points that are not entierly covered +! by ice. +! The routine receives data from climatologie file limit.nc and does some calculations at the +! surface. +! + USE dimphy + USE calcul_fluxs_mod + USE limit_read_mod + USE mod_grid_phy_lmdz + USE indice_sol_mod + USE surface_data, ONLY : iflag_leads + USE phys_output_var_mod, ONLY : sens_prec_liq_o, sens_prec_sol_o, lat_prec_liq_o, lat_prec_sol_o + use config_ocean_skin_m, only: activate_ocean_skin +#ifdef ISO + USE infotrac_phy, ONLY: ntiso,niso + USE isotopes_routines_mod, ONLY: calcul_iso_surf_oce_vectall, calcul_iso_surf_sic_vectall +#ifdef ISOVERIF + USE isotopes_mod, ONLY: iso_eau,ridicule + !USE isotopes_verif_mod, ONLY: errmax,errmaxrel,iso_verif_egalite_choix + USE isotopes_verif_mod +#endif +#endif +USE flux_arp_mod_h + USE clesphys_mod_h + USE yomcst_mod_h + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragq, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, gustiness + REAL, DIMENSION(klon), INTENT(IN) :: tsurf_in + real, intent(in):: rhoa(:) ! (knon) density of moist air (kg / m3) +!GG + REAL, DIMENSION(klon), INTENT(IN) :: dthetadz300 + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf +! + +#ifdef ISO + REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtprecip_rain, xtprecip_snow + REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtspechum + REAL, DIMENSION(klon), INTENT(IN) :: rlat +#endif + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno !? put to 0 in ocean +#ifdef ISO + REAL, DIMENSION(niso,klon), INTENT(IN) :: xtsnow + REAL, DIMENSION(niso,klon), INTENT(INOUT):: Roce +#endif + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, INTENT(out):: sens_prec_liq(:) ! (knon) +!GG + REAL, DIMENSION(klon), INTENT(OUT) :: Ampl +! + +#ifdef ISO + REAL, DIMENSION(ntiso,klon), INTENT(OUT) :: xtevap ! isotopes in evaporation flux + REAL, DIMENSION(klon), INTENT(OUT) :: h1 ! just a diagnostic, not useful for the simulation +#endif + +! Local variables +!**************************************************************************************** + INTEGER :: i, j + REAL, DIMENSION(klon) :: cal, beta, dif_grnd + REAL, DIMENSION(klon) :: alb_neig, tsurf_lim, zx_sl + REAL, DIMENSION(klon) :: u0, v0 + REAL, DIMENSION(klon) :: u1_lay, v1_lay + LOGICAL :: check=.FALSE. + REAL, DIMENSION(knon) :: sens_prec_sol + REAL, DIMENSION(klon) :: lat_prec_liq, lat_prec_sol +! GG + REAL, DIMENSION(klon) :: l_CBL, sicfra +! +#ifdef ISO + REAL, PARAMETER :: t_coup = 273.15 +#endif + + +!**************************************************************************************** +! Start calculation +!**************************************************************************************** + IF (check) WRITE(*,*)' Entering ocean_forced_noice' + +#ifdef ISO +#ifdef ISOVERIF + DO i = 1, knon + IF (iso_eau > 0) THEN + CALL iso_verif_egalite_choix(xtspechum(iso_eau,i), & + & spechum(i),'ocean_forced_mod 111', & + & errmax,errmaxrel) + CALL iso_verif_egalite_choix(snow(i), & + & xtsnow(iso_eau,i),'ocean_forced_mod 117', & + & errmax,errmaxrel) + ENDIF !IF (iso_eau > 0) THEN + ENDDO !DO i=1,knon +#endif +#endif + +!**************************************************************************************** +! 1) +! Read sea-surface temperature from file limit.nc +! +!**************************************************************************************** +!--sb: +!!jyg if (knon.eq.1) then ! single-column model + if (klon_glo.eq.1) then ! single-column model + ! EV: now surface Tin flux_arp.h + !CALL read_tsurf1d(knon,tsurf_lim) ! new + DO i = 1, knon + tsurf_lim(i) = tg + ENDDO + + else ! GCM + CALL limit_read_sst(knon,knindex,tsurf_lim & +#ifdef ISO + & ,Roce,rlat & +#endif + & ) + endif ! knon +!sb-- + +!**************************************************************************************** +! 2) +! Flux calculation +! +!**************************************************************************************** +! Set some variables for calcul_fluxs + !cal = 0. + !beta = 1. + !dif_grnd = 0. + + + ! EV: use calbeta to calculate beta + ! Need to initialize qsurf for calbeta but it is not modified by this routine + qsurf(:)=0. + CALL calbeta(dtime, is_oce, knon, snow, qsurf, beta, cal, dif_grnd) + + + alb_neig(:) = 0. + agesno(:) = 0. + lat_prec_liq = 0.; lat_prec_sol = 0. + +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + +! Calcul de tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l and qsurf + CALL calcul_fluxs(knon, is_oce, dtime, & + merge(tsurf_in, tsurf_lim, activate_ocean_skin == 2), p1lay, cal, & + beta, cdragh, cdragq, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, & + f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, & + sens_prec_liq, sens_prec_sol, lat_prec_liq, lat_prec_sol, rhoa) + if (activate_ocean_skin == 2) tsurf_new = tsurf_lim + + do j = 1, knon + i = knindex(j) + sens_prec_liq_o(i,1) = sens_prec_liq(j) + sens_prec_sol_o(i,1) = sens_prec_sol(j) + lat_prec_liq_o(i,1) = lat_prec_liq(j) + lat_prec_sol_o(i,1) = lat_prec_sol(j) + enddo + +!GG + if (iflag_leads == 1) then + l_CBL = -52381.*dthetadz300 + 3008.1 + Ampl = 6.012e-08*l_CBL**2 - 4.036e-04*l_CBL + 1.4979 + WHERE(Ampl(:)>1.2) Ampl(:)=1.2 + sicfra(:)=pctsrf(:,is_sic)/(1.-pctsrf(:,is_lic)-pctsrf(:,is_ter)) + WHERE(pctsrf(:,is_sic)+pctsrf(:,is_oce)0.7).and.(sicfra<0.9)) Ampl=((sicfra-0.7)/0.2)*Ampl+((0.9-sicfra)/0.2) + fluxsens=Ampl*fluxsens + dflux_s=Ampl*dflux_s + endif + + +! - Flux calculation at first modele level for U and V + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, gustiness, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + +#ifdef ISO + CALL calcul_iso_surf_oce_vectall(klon, knon,t_coup, & + & ps,tsurf_new,spechum,u1_lay, v1_lay, xtspechum, & + & evap, Roce,xtevap,h1 & +#ifdef ISOTRAC + & ,knindex & +#endif + & ) +#endif + +#ifdef ISO +#ifdef ISOVERIF +! write(*,*) 'ocean_forced_mod 176: sortie de ocean_forced_noice' + IF (iso_eau > 0) THEN + DO i = 1, knon + CALL iso_verif_egalite_choix(snow(i), & + & xtsnow(iso_eau,i),'ocean_forced_mod 180', & + & errmax,errmaxrel) + ENDDO ! DO j=1,knon + ENDIF !IF (iso_eau > 0) THEN +#endif +#endif + + END SUBROUTINE ocean_forced_noice +! +!*************************************************************************************** +! + SUBROUTINE ocean_forced_ice( & + itime, dtime, jour, knon, knindex, & + tsurf_in, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air,spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & +!GG ps, u1, v1, gustiness, & + ps, u1, v1, gustiness, pctsrf, & +!GG + radsol, snow, qsol, agesno, tsoil, & + qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & +!GG tsurf_new, dflux_s, dflux_l, rhoa) + tsurf_new, dflux_s, dflux_l, rhoa, swnet, hice, tice, bilg_cumul, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic & +!GG +#ifdef ISO + ,xtprecip_rain, xtprecip_snow, xtspechum,Roce, & + xtsnow, xtsol,xtevap,Rland_ice & +#endif + ) +! +! This subroutine treats the ocean where there is ice. +! The routine reads data from climatologie file and does flux calculations at the +! surface. +! + USE dimphy + USE geometry_mod, ONLY: longitude,latitude + USE calcul_fluxs_mod +!GG USE surface_data, ONLY : calice, calsno + USE surface_data, ONLY : calice, calsno, iflag_seaice, iflag_seaice_alb, & + sice_cond, sisno_cond, sisno_den, sisno_min, sithick_min, sisno_wfact, & + amax_s,amax_n, rn_alb_sdry, rn_alb_smlt, rn_alb_idry, rn_alb_imlt, & + si_pen_frac, si_pen_ext, fseaN, fseaS, iflag_leads + + USE geometry_mod, ONLY: longitude,latitude,latitude_deg +!GG + USE limit_read_mod + USE fonte_neige_mod, ONLY : fonte_neige + USE indice_sol_mod + USE phys_output_var_mod, ONLY : sens_prec_liq_o, sens_prec_sol_o, lat_prec_liq_o, lat_prec_sol_o +#ifdef ISO + USE infotrac_phy, ONLY: niso, ntiso + USE isotopes_routines_mod, ONLY: calcul_iso_surf_oce_vectall, calcul_iso_surf_sic_vectall +#ifdef ISOVERIF + USE isotopes_mod, ONLY: iso_eau,ridicule + !USE isotopes_verif_mod, ONLY: errmax,errmaxrel,iso_verif_egalite_choix + USE isotopes_verif_mod +#endif +#endif +USE flux_arp_mod_h + USE clesphys_mod_h + USE yomcst_mod_h +USE dimsoil_mod_h, ONLY: nsoilmx + +! INCLUDE "indicesol.h" + + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: tsurf_in + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, gustiness + real, intent(in):: rhoa(:) ! (knon) density of moist air (kg / m3) +!GG + REAL, DIMENSION(klon), INTENT(IN) :: swnet + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf +!GG +#ifdef ISO + REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtprecip_rain, xtprecip_snow + REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtspechum + REAL, DIMENSION(niso,klon), INTENT(IN) :: Roce + REAL, DIMENSION(niso,klon), INTENT(IN) :: Rland_ice +#endif + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil +!GG + REAL, DIMENSION(klon), INTENT(INOUT) :: hice + REAL, DIMENSION(klon), INTENT(INOUT) :: tice + REAL, DIMENSION(klon), INTENT(INOUT) :: bilg_cumul + REAL, DIMENSION(klon), INTENT(INOUT) :: fcds + REAL, DIMENSION(klon), INTENT(INOUT) :: fcdi + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_basal_growth + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_basal_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_top_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_snow2sic + REAL, DIMENSION(klon), INTENT(INOUT) :: dtice_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dtice_snow2sic +!GG +#ifdef ISO + REAL, DIMENSION(niso,klon), INTENT(INOUT) :: xtsnow + REAL, DIMENSION(niso,klon), INTENT(IN) :: xtsol +#endif + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new ! new albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(OUT) :: alb2_new ! new albedo in near IR interval + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l +#ifdef ISO + REAL, DIMENSION(ntiso,klon), INTENT(OUT) :: xtevap +#endif + +! Local variables +!**************************************************************************************** + LOGICAL :: check=.FALSE. + INTEGER :: i, j + REAL :: zfra + REAL, PARAMETER :: t_grnd=271.35 + REAL, DIMENSION(klon) :: cal, beta, dif_grnd, capsol, icesub + REAL, DIMENSION(klon) :: alb_neig, tsurf_tmp + REAL, DIMENSION(klon) :: soilcap, soilflux + REAL, DIMENSION(klon) :: u0, v0 + REAL, DIMENSION(klon) :: u1_lay, v1_lay + REAL, DIMENSION(knon) :: sens_prec_liq, sens_prec_sol + REAL, DIMENSION(klon) :: lat_prec_liq, lat_prec_sol +!GG + INTEGER :: ki + INTEGER :: cpl_pas + REAL, DIMENSION(klon) :: bilg, fsic, f_bot + REAL, PARAMETER :: latent_ice = 334.0e3 + REAL, PARAMETER :: rau_ice = 917.0 + REAL, PARAMETER :: kice=2.2 + REAL :: f_cond, f_swpen, f_cond_s, f_cond_i + REAL :: ustar, uscap, ustau + ! for snow/ice albedo: + REAL :: alb_snow, alb_ice, alb_pond + REAL :: frac_snow, frac_ice, frac_pond + REAL :: z1_i, z2_i, z1_s, zlog ! height parameters + ! for ice melt / freeze + REAL :: e_melt, snow_evap, h_test + ! dhsic, dfsic change in ice mass, fraction. + REAL :: dhsic, dfsic, frac_mf + REAL :: fsea, amax + REAL :: hice_i, tice_i, fsic_new +! snow and ice physical characteristics: + REAL, PARAMETER :: t_freeze=271.35 ! freezing sea water temp + REAL, PARAMETER :: t_melt=273.15 ! melting ice temp + REAL :: sno_den!=sisno_den !mean snow density, kg/m3 + REAL, PARAMETER :: ice_den=917. ! ice density + REAL, PARAMETER :: sea_den=1025. ! sea water density + REAL :: ice_cond!=sice_cond*ice_den !conductivity of ice + REAL :: sno_cond!=sisno_cond*sno_den ! conductivity of snow + REAL, PARAMETER :: ice_cap=2067. ! specific heat capacity, snow and ice + REAL, PARAMETER :: sea_cap=3995. ! specific heat capacity, water + REAL, PARAMETER :: ice_lat=334000. ! freeze /melt latent heat snow and ice + +! control of snow and ice cover & freeze / melt (heights converted to kg/m2) + REAL :: snow_min!=sisno_min*sno_den !critical snow height 5 cm + REAL :: snow_wfact!=sisno_wfact ! max fraction of falling snow blown into ocean + REAL, PARAMETER :: ice_frac_min=0.005 + REAL :: h_ice_min!=sithick_min ! min ice thickness + ! below ice_thin, priority is melt lateral / grow height + ! ice_thin is also height of new ice + REAL, PARAMETER :: h_ice_max=7 ! max ice height + ! Ice thickness parameter for lateral growth + REAL, PARAMETER :: h_ice_thick=1.5 + REAL, PARAMETER :: h_ice_thin=0.15 + +! albedo and radiation parameters + INTEGER, SAVE :: iflag_sic_albedo +! albedo old or NEMO + REAL :: alb_sno_dry!=rn_alb_sdry !dry snow albedo + REAL :: alb_sno_wet!=rn_alb_smlt !wet snow albedo + REAL :: alb_ice_dry!=rn_alb_idry !dry thick ice + REAL :: alb_ice_wet!=rn_alb_imlt !melting thick ice +! new (Toyoda 2020) albedo +! Values for snow / ice, dry / melting, visible / near IR + REAL, PARAMETER :: alb_sdry_vis=0.98 + REAL, PARAMETER :: alb_smlt_vis=0.88 + REAL, PARAMETER :: alb_sdry_nir=0.7 + REAL, PARAMETER :: alb_smlt_nir=0.55 + REAL, PARAMETER :: alb_idry_vis=0.78 + REAL, PARAMETER :: alb_imlt_vis=0.705 + REAL, PARAMETER :: alb_idry_nir=0.36 + REAL, PARAMETER :: alb_imlt_nir=0.285 + REAL, PARAMETER :: h_ice_alb=0.5*ice_den ! height for full ice albedo + REAL, PARAMETER :: h_sno_alb=0.02*300 ! height for control of snow fraction + + REAL :: pen_frac !=si_pen_frac !fraction of shortwave penetrating into the + ! ice (not snow). Should be visible only, not NIR + REAL :: pen_ext !=si_pen_ext !extinction length of penetrating shortwave (m-1) + +! HF from ocean below ice +! REAL, PARAMETER :: fseaN=2.0 ! NH +! REAL, PARAMETER :: fseaS=4.0 ! SH +!GG + +#ifdef ISO + REAL, PARAMETER :: t_coup = 273.15 + REAL, DIMENSION(klon) :: fq_fonte_diag + REAL, DIMENSION(klon) :: fqfonte_diag + REAL, DIMENSION(klon) :: snow_evap_diag + REAL, DIMENSION(klon) :: fqcalving_diag + REAL, DIMENSION(klon) :: run_off_lic_diag + REAL :: coeff_rel_diag + REAL :: max_eau_sol_diag + REAL, DIMENSION(klon) :: runoff_diag + INTEGER IXT + REAL, DIMENSION(niso,klon) :: xtsnow_prec, xtsol_prec + REAL, DIMENSION(klon) :: snow_prec, qsol_prec +#endif + +!**************************************************************************************** +! Start calculation +!**************************************************************************************** + IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon + +!**************************************************************************************** +! 1) +! Flux calculation : tsurf_new, evap, fluxlat, fluxsens, flux_u1, flux_v1 +! dflux_s, dflux_l and qsurf +!**************************************************************************************** + + tsurf_tmp(:) = tsurf_in(:) + +!GG + IF (iflag_seaice==0) THEN ! Old LMDZ sea ice surface +!GG +! calculate the parameters cal, beta, capsol and dif_grnd and then recalculate cal + CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, capsol, dif_grnd) + + + IF (soil_model) THEN +! update tsoil and calculate soilcap and soilflux + CALL soil(dtime, is_sic, knon, snow, tsurf_tmp, qsol, & + & longitude(knindex(1:knon)), latitude(knindex(1:knon)), tsoil,soilcap, soilflux) + cal(1:knon) = RCPD / soilcap(1:knon) + radsol(1:knon) = radsol(1:knon) + soilflux(1:knon) + dif_grnd = 1.0 / tau_gl + ELSE + dif_grnd = 1.0 / tau_gl + cal = RCPD * calice + WHERE (snow > 0.0) cal = RCPD * calsno + ENDIF + +!GG + ELSEIF (iflag_seaice==2) THEN + + sno_den=sisno_den !mean snow density, kg/m3 + ice_cond=sice_cond*ice_den !conductivity of ice + sno_cond=sisno_cond*sno_den ! conductivity of snow + snow_min=sisno_min*sno_den !critical snow height 5 cm + snow_wfact=sisno_wfact ! max fraction of falling snow blown into ocean + h_ice_min=sithick_min ! min ice thickness + alb_sno_dry=rn_alb_sdry !dry snow albedo + alb_sno_wet=rn_alb_smlt !wet snow albedo + alb_ice_dry=rn_alb_idry !dry thick ice + alb_ice_wet=rn_alb_imlt !melting thick ice + pen_frac=si_pen_frac !fraction of shortwave penetrating into the + pen_ext=si_pen_ext !extinction length of penetrating shortwave (m-1) + + bilg(:)=0. + dif_grnd(:)=0. + beta(:) = 1. + fsic(:) = pctsrf(:,is_sic) + cpl_pas = NINT(86400./dtime * 1.0) ! une fois par jour + + ! Surface, snow-ice and ice-ocean fluxes. +! Prepare call to calcul_fluxs (cal, beta, radsol, dif_grnd) + + !write(*,*) 'radsol 1',radsol(1:100) + DO i=1,knon + ki=knindex(i) + IF (snow(i).GT.snow_min) THEN + ! 1 / snow-layer heat capacity + cal(i)=2.*RCPD/(snow(i)*ice_cap) + ! adjustment time-scale of conductive flux + dif_grnd(i) = cal(i) * sno_cond / snow(i) / RCPD + ! for conductive flux + f_cond_s = sno_cond * (tice(ki)-t_freeze) / snow(i) + radsol(i) = radsol(i)+f_cond_s + ! all shortwave flux absorbed + f_swpen=0. + ELSE ! bare ice. + f_cond_s = 0. + ! 1 / ice-layer heat capacity + cal(i) = 2.*RCPD/(hice(ki)*ice_den*ice_cap) + ! adjustment time-scale of conductive flux + dif_grnd(i) = cal(i) * ice_cond / (hice(ki)*ice_den) / RCPD + ! penetrative shortwave flux... + f_swpen=swnet(i)*pen_frac*exp(-pen_ext*hice(ki)) + radsol(i) = radsol(i)-f_swpen + ! GG no conductive flux in this case? + END IF + bilg(ki)=f_swpen-f_cond_s + END DO + + endif + +! beta = 1.0 + lat_prec_liq = 0.; lat_prec_sol = 0. + +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + CALL calcul_fluxs(knon, is_sic, dtime, & + tsurf_tmp, p1lay, cal, beta, cdragh, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, & + f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, & + sens_prec_liq, sens_prec_sol, lat_prec_liq, lat_prec_sol, rhoa) + do j = 1, knon + i = knindex(j) + sens_prec_liq_o(i,2) = sens_prec_liq(j) + sens_prec_sol_o(i,2) = sens_prec_sol(j) + lat_prec_liq_o(i,2) = lat_prec_liq(j) + lat_prec_sol_o(i,2) = lat_prec_sol(j) + enddo + +! - Flux calculation at first modele level for U and V + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, gustiness, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + +!**************************************************************************************** +! 2) +! Calculations due to snow and runoff +! +!**************************************************************************************** +!GG + if (iflag_seaice==0) then +!GG +#ifdef ISO + ! verif +#ifdef ISOVERIF + DO i = 1, knon + IF (iso_eau > 0) THEN + IF (snow(i) > ridicule) THEN + CALL iso_verif_egalite_choix(xtsnow(iso_eau,i),snow(i), & + & 'interfsurf 964',errmax,errmaxrel) + ENDIF !IF ((snow(i) > ridicule)) THEN + ENDIF !IF (iso_eau > 0) THEN + ENDDO !DO i=1,knon +#endif + ! end verif + + DO i = 1, knon + snow_prec(i) = snow(i) + DO ixt = 1, niso + xtsnow_prec(ixt,i) = xtsnow(ixt,i) + ENDDO !DO ixt=1,niso + ! initialisation: + fq_fonte_diag(i) = 0.0 + fqfonte_diag(i) = 0.0 + snow_evap_diag(i)= 0.0 + ENDDO !DO i=1,knon +#endif + + + CALL fonte_neige( knon, is_sic, knindex, dtime, & + tsurf_tmp, precip_rain, precip_snow, & + snow, qsol, tsurf_new, evap, icesub & +#ifdef ISO + & ,fq_fonte_diag,fqfonte_diag,snow_evap_diag,fqcalving_diag & + & ,max_eau_sol_diag,runoff_diag,run_off_lic_diag,coeff_rel_diag & +#endif + & ) + + +#ifdef ISO +! isotopes: tout est externalisé +!#ifdef ISOVERIF +! write(*,*) 'ocean_forced_mod 377: call calcul_iso_surf_sic_vectall' +! write(*,*) 'klon,knon=',klon,knon +!#endif + CALL calcul_iso_surf_sic_vectall(klon,knon, & + & evap,snow_evap_diag,Tsurf_new,Roce,snow, & + & fq_fonte_diag,fqfonte_diag,dtime,t_coup, & + & precip_snow,xtprecip_snow,xtprecip_rain, snow_prec,xtsnow_prec, & + & xtspechum,spechum,ps, & + & xtevap,xtsnow,fqcalving_diag, & + & knindex,is_sic,run_off_lic_diag,coeff_rel_diag,Rland_ice & + & ) +#ifdef ISOVERIF + !write(*,*) 'ocean_forced_mod 391: sortie calcul_iso_surf_sic_vectall' + IF (iso_eau > 0) THEN + DO i = 1, knon + CALL iso_verif_egalite_choix(snow(i), & + & xtsnow(iso_eau,i),'ocean_forced_mod 396', & + & errmax,errmaxrel) + ENDDO ! DO j=1,knon + ENDIF !IF (iso_eau > 0) then +#endif +!#ifdef ISOVERIF +#endif +!#ifdef ISO + +! Calculation of albedo at snow (alb_neig) and update the age of snow (agesno) +! + CALL albsno(klon, knon, dtime, agesno(:), alb_neig(:), precip_snow(:)) + + WHERE (snow(1:knon) .LT. 0.0001) agesno(1:knon) = 0. + + alb1_new(:) = 0.0 + DO i=1, knon + zfra = MAX(0.0,MIN(1.0,snow(i)/(snow(i)+10.0))) + alb1_new(i) = alb_neig(i) * zfra + 0.6 * (1.0-zfra) + ENDDO + + alb2_new(:) = alb1_new(:) + +!GG + else + + DO i=1,knon + ki=knindex(i) + + ! ocean-ice heat flux + fsea=fseaS + amax=amax_s + if (latitude(ki)>0) THEN + fsea=fseaN + amax=amax_n + ENDIF + + IF (snow(i).GT.snow_min) THEN + ! snow conductive flux after calcul_fluxs (pos up) + f_cond_s = sno_cond * (tice(ki)-tsurf_new(i)) / snow(i) + ! 1 / heat capacity and conductive timescale + uscap = 2. / ice_cap / (snow(i)+hice(ki)*ice_den) + ustau = uscap * ice_cond / (hice(ki)*ice_den) + ! update ice temp + tice(ki) = (tice(ki) + dtime*(ustau*t_freeze - uscap*f_cond_s)) & + / (1 + dtime*ustau) + ELSE ! bare ice + tice(ki)=tsurf_new(i) + ENDIF + ! ice conductive flux (pos up) + f_cond_i = ice_cond * (t_freeze-tice(ki)) / (hice(ki)*ice_den) + f_bot(i) = fsea - f_cond_i + fcdi(ki) = f_cond_i - fsea + fcds(i) = f_cond_s + !bilg(ki) = bilg(ki)+f_cond_i + END DO + +!**************************************************************************************** +! 2) Update snow and ice surface : thickness +!**************************************************************************************** + + IF (iflag_seaice==1) THEN +! Read from limit + CALL limit_read_hice(knon,knindex,hice) + ENDIF +! Formula Krinner et al. 1997 : h = (0.2 + 3.8(f_min**2))(1 + 2(f- f_min)) + + + + DO i=1,knon + ki=knindex(i) + IF (precip_snow(i) > 0.) THEN + snow(i) = snow(i)+precip_snow(i)*dtime*(1.-snow_wfact*(1.-fsic(ki))) + END IF +! snow and ice sublimation + IF (evap(i) > 0.) THEN + snow_evap = MIN (snow(i) / dtime, evap(i)) + snow(i) = snow(i) - snow_evap * dtime + snow(i) = MAX(0.0, snow(i)) + IF (iflag_seaice==2) THEN + hice(ki) = MAX(0.0,hice(ki)-(evap(i)-snow_evap)*dtime/ice_den) + ENDIF + ENDIF +! Melt / Freeze snow from above if Tsurf>0 + IF (tsurf_new(i).GT.t_melt) THEN + ! energy available for melting snow (in kg of melted snow /m2) + e_melt = MIN(MAX(snow(i)*(tsurf_new(i)-t_melt)*ice_cap/2. & + /(ice_lat+ice_cap/2.*(t_melt-tice(ki))),0.0),snow(i)) + ! remove snow + tice_i=tice(ki) + IF (snow(i).GT.e_melt) THEN + snow(i)=snow(i)-e_melt + tsurf_new(i)=t_melt + ELSE ! all snow is melted + ! add remaining heat flux to ice + e_melt=e_melt-snow(i) + tice(ki)=tice(ki)+e_melt*ice_lat*2./(ice_cap*hice(ki)*ice_den) + tsurf_new(i)=tice(ki) + END IF + dtice_melt(ki)=(tice(ki)-tice_i)/dtime + END IF +! Bottom melt / grow +! bottom freeze if bottom flux (cond + oce-ice) <0 + IF (iflag_seaice==2) THEN + IF (f_bot(i).LT.0) THEN + ! larger fraction of bottom growth + frac_mf=MIN(1.,MAX(0.,(hice(ki)-h_ice_thick) & + / (h_ice_max-h_ice_thick))) + ! quantity of new ice (formed at mean ice temp) + e_melt= -f_bot(i) * dtime * fsic(ki) & + / (ice_lat+ice_cap/2.*(t_freeze-tice(ki))) + ! first increase height to h_thick + dhsic=MAX(0.,MIN(h_ice_thick-hice(ki),e_melt/(fsic(ki)*ice_den))) + hice_i=hice(ki) + hice(ki)=dhsic+hice(ki) + e_melt=e_melt-fsic(ki)*dhsic + IF (e_melt.GT.0.) THEN + ! frac_mf fraction used for lateral increase + dfsic=MIN(amax-fsic(ki),e_melt*frac_mf/ (hice(ki)*ice_den) ) + ! No lateral growth -> forced ocean + !fsic(ki)=fsic(ki)+dfsic + e_melt=e_melt-dfsic*hice(ki)*ice_den + ! rest used to increase height + hice(ki)=MIN(h_ice_max,hice(ki)+e_melt/( fsic(ki) * ice_den ) ) + END IF + dh_basal_growth(ki)=(hice(ki)-hice_i)/dtime + +! melt from below if bottom flux >0 + ELSE + ! larger fraction of lateral melt from warm ocean + frac_mf=MIN(1.,MAX(0.,(hice(ki)-h_ice_thin) & + / (h_ice_thick-h_ice_thin))) + ! bring ice to freezing and melt from below + ! quantity of melted ice + e_melt= f_bot(i) * dtime * fsic(ki) & + / (ice_lat+ice_cap/2.*(tice(ki)-t_freeze)) + ! first decrease height to h_thick + hice_i=hice(ki) + dhsic=MAX(0.,MIN(hice(ki)-h_ice_thick,e_melt/(fsic(ki)*ice_den))) + hice(ki)=hice(ki)-dhsic + e_melt=e_melt-fsic(ki)*dhsic*ice_den + + IF (e_melt.GT.0) THEN + ! frac_mf fraction used for height decrease + dhsic=MAX(0.,MIN(hice(ki)-h_ice_min,e_melt/ice_den*frac_mf/fsic(ki))) + hice(ki)=hice(ki)-dhsic + e_melt=e_melt-fsic(ki)*dhsic*ice_den + ! rest used to decrease fraction (up to 0!) + dfsic=MIN(fsic(ki),e_melt/(hice(ki)*ice_den)) + ! Remaining heat not used if everything melted + e_melt=e_melt-dfsic*hice(ki)*ice_den + ! slab_bilg(ki) = slab_bilg(ki) + e_melt*ice_lat/dtime + END IF + dh_basal_melt(ki)=(hice(ki)-hice_i)/dtime + END IF + END IF + +! melt ice from above if Tice>0 + tice_i=tice(ki) + IF (tice(ki).GT.t_melt) THEN + IF (iflag_seaice==2) THEN + ! quantity of ice melted (kg/m2) + e_melt=MAX(hice(ki)*ice_den*(tice(ki)-t_melt)*ice_cap/2. & + /(ice_lat+ice_cap/2.*(t_melt-t_freeze)),0.0) + ! melt from above, height only + hice_i=hice(ki) + dhsic=MIN(hice(ki)-h_ice_min,e_melt/ice_den) + dh_top_melt(i)=dhsic + e_melt=e_melt-dhsic + IF (e_melt.GT.0) THEN + ! lateral melt if ice too thin + dfsic=MAX(fsic(ki)-ice_frac_min,e_melt/(h_ice_min*ice_den)*fsic(ki)) + ! if all melted do nothing with remaining heat + e_melt=MAX(0.,e_melt*fsic(ki)-dfsic*h_ice_min*ice_den) + ! slab_bilg(ki) = slab_bilg(ki) + e_melt*ice_lat/dtime + END IF + hice(ki)=hice(ki)-dhsic + dh_top_melt(ki)=(hice(ki)-hice_i)/dtime + ! surface temperature at melting point + END IF + tice(ki)=t_melt + tsurf_new(i)=t_melt + END IF + dtice_melt(ki)=dtice_melt(ki)+tice(ki)-tice_i + + ! convert snow to ice if below floating line + h_test=(hice(ki)*ice_den+snow(i))-hice(ki)*sea_den + IF ((h_test.GT.0.).AND.(hice(ki).GT.h_ice_min)) THEN !snow under water + ! extra snow converted to ice (with added frozen sea water) + IF (iflag_seaice==2) THEN + dhsic=h_test/(sea_den-ice_den+sno_den) + hice(ki)=hice(ki)+dhsic + ENDIF + snow(i)=snow(i)-dhsic*sno_den + ! available energy (freeze sea water + bring to tice) + e_melt=dhsic*ice_den*(1.-sno_den/ice_den)*(ice_lat+ & + ice_cap/2.*(t_freeze-tice(ki))) + ! update ice temperature + tice_i=tice(ki) + tice(ki)=tice(ki)+2.*e_melt/ice_cap/(snow(i)+hice(ki)*ice_den) + IF (iflag_seaice==2) THEN + dh_snow2sic(ki)=dhsic/dtime + END IF + dtice_snow2sic(ki)=(tice(ki)-tice_i)/dtime + END IF + END DO + + !write(*,*) 'hice 2',hice(1:100) + !write(*,*) 'tice 2',tice(1:100) + + iflag_sic_albedo=iflag_seaice_alb + +!******************************************************************************* +! 3) cumulate ice-ocean fluxes, update tslab, lateral grow +!***********************************************o******************************* + !cumul fluxes. + bilg_cumul(:)=bilg_cumul(:)+bilg(:)/float(cpl_pas) + IF (MOD(itime,cpl_pas).EQ.0) THEN ! time to update tslab + bilg_cumul(:)=0. + END IF ! coupling time + +! write(*,*) 'hice 3',hice(1:100) +! write(*,*) 'tice 3',tice(1:100) + !tests ice fraction + WHERE (fsic.LT.ice_frac_min) + tice=t_melt + hice=h_ice_min + END WHERE + + !write(*,*) 'hice 4',hice(1:100) + !write(*,*) 'tice 4',tice(1:100) + + endif + +!**************************************************************************************** +! 4) Compute sea-ice and snow albedo +!**************************************************************************************** + IF (iflag_seaice > 0) THEN + SELECT CASE (iflag_sic_albedo) + CASE(0) +! old slab albedo : single value. age of snow, melt ponds. + DO i=1,knon + ki=knindex(i) + ! snow albedo: update snow age + IF (snow(i).GT.0.0001) THEN + agesno(i)=(agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)& + * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/5.) + ELSE + agesno(i)=0.0 + END IF + ! snow albedo + alb_snow=alb_sno_wet+(alb_sno_dry-alb_sno_wet)*EXP(-agesno(i)/50.) + ! ice albedo (varies with ice tkickness and temp) + alb_ice=MAX(0.0,0.13*LOG(100.*hice(ki))+0.1) + !alb_ice=MAX(0.0,0.13*LOG(100.*seaice(ki)/ice_den)+0.1) + IF (tice(ki).GT.t_freeze-0.01) THEN + alb_ice=MIN(alb_ice,alb_ice_wet) + ELSE + alb_ice=MIN(alb_ice,alb_ice_dry) + END IF + ! pond albedo + alb_pond=0.36-0.1*(2.0+MIN(0.0,MAX(tice(ki)-t_melt,-2.0))) + ! pond fraction + frac_pond=0.2*(2.0+MIN(0.0,MAX(tice(ki)-t_melt,-2.0))) + ! snow fraction + frac_snow=MAX(0.0,MIN(1.0-frac_pond,snow(i)/snow_min)) + ! ice fraction + frac_ice=MAX(0.0,1.-frac_pond-frac_snow) + ! total albedo + alb1_new(i)=alb_snow*frac_snow+alb_ice*frac_ice+alb_pond*frac_pond + END DO + alb2_new(:) = alb1_new(:) + + CASE(1) +! New visible and IR albedos, dry / melting snow +! based on Toyoda et al, 2020 + DO i=1,knon + ki=knindex(i) + ! snow fraction + frac_snow = snow(i) / (snow(i) + h_sno_alb) + ! dependence of ice albedo with ice thickness + frac_ice = MIN(1.,ATAN(4.*hice(ki)*ice_den) / ATAN(4.*h_ice_alb)) + ! Total (for ice, min = 0.066 = alb_ocean) + IF (tice(ki).GT.t_melt) THEN + alb_ice = 0.066 + (alb_imlt_vis - 0.066)*frac_ice + alb1_new(i)=alb_smlt_vis*frac_snow + alb_ice*(1.-frac_snow) + alb_ice = 0.066 + (alb_imlt_nir - 0.066)*frac_ice + alb2_new(i)=alb_smlt_nir*frac_snow + alb_ice*(1.-frac_snow) + ELSEIF (tice(ki).GT.t_melt - 1.) THEN + frac_pond = tice(ki) - t_freeze + alb_snow = alb_smlt_vis*frac_pond + alb_sdry_vis*(1.-frac_pond) + alb_ice = alb_imlt_vis*frac_pond + alb_idry_vis*(1.-frac_pond) + alb_ice = 0.066 + (alb_ice - 0.66)*frac_ice + alb1_new(i)= alb_snow*frac_snow + alb_ice*(1.-frac_snow) + alb_snow = alb_smlt_nir*frac_pond + alb_sdry_nir*(1.-frac_pond) + alb_ice = alb_imlt_nir*frac_pond + alb_idry_nir*(1.-frac_pond) + alb_ice = 0.066 + (alb_ice - 0.66)*frac_ice + alb2_new(i)= alb_snow*frac_snow + alb_ice*(1.-frac_snow) + ELSE + alb_ice = 0.066 + (alb_idry_vis - 0.066)*frac_ice + alb1_new(i)=alb_sdry_vis*frac_snow + alb_ice*(1.-frac_snow) + alb_ice = 0.066 + (alb_idry_nir - 0.066)*frac_ice + alb2_new(i)=alb_sdry_nir*frac_snow + alb_ice*(1.-frac_snow) + ENDIF + END DO + + CASE(2) +! LIM3 scheme. Uses clear sky / overcast value, with 50% clear sky + z1_i = 1.5 * ice_den + z2_i = 0.05 * ice_den + zlog = 1. / (LOG(1.5) - LOG(0.05)) + z1_s = 1. / (0.025 * sno_den) + DO i=1,knon + ki=knindex(i) + ! temperature above / below 0 + IF (tice(ki).GE.t_melt) THEN + alb_ice = alb_ice_wet + alb_snow = alb_sno_wet + ELSE + alb_ice = alb_ice_dry + alb_snow = alb_sno_dry + ENDIF + ! ice thickness + IF (hice(ki)*ice_den.LT.z2_i) THEN + alb_ice = 0.066 + 0.114 * hice(ki)*ice_den / z2_i + ELSEIF (hice(ki)*ice_den.LT.z1_i) THEN + alb_ice = alb_ice + (0.18 - alb_ice) & + * (LOG(z1_i) - LOG(hice(ki)*ice_den)) * zlog + ENDIF + ! ice or snow depending on snow thickness + alb_snow = alb_snow - (alb_snow -alb_ice) * EXP(- snow(i) * z1_s) + ! Effect of clouds (polynomial fit with 50% clouds) + alb1_new(i) = alb_snow - 0.5 * (-0.1010 * alb_snow*alb_snow & + + 0.1933*alb_snow - 0.0148) + alb2_new(i) = alb1_new(i) + END DO + + CASE(3) + CALL albsno(klon, knon, dtime, agesno(:), alb_neig(:), precip_snow(:)) + WHERE (snow(1:knon) .LT. 0.0001) agesno(1:knon) = 0. + alb1_new(:) = 0.0 + DO i=1, knon + zfra = MAX(0.0,MIN(1.0,snow(i)/(snow(i)+10.0))) + alb1_new(i) = alb_neig(i) * zfra + 0.6 * (1.0-zfra) + ENDDO + alb2_new(:) = alb1_new(:) + + print*,'alb_neig=',alb_neig + print*,'zfra=',zfra + print*,'snow=',snow + print*,'alb1_new=',alb1_new + print*,'alb2_new=',alb2_new + END SELECT + END IF +! ------ End Albedo ---------- + +!GG + END SUBROUTINE ocean_forced_ice + +!************************************************************************ +! 1D case +!************************************************************************ +! SUBROUTINE read_tsurf1d(knon,sst_out) +! +! This subroutine specifies the surface temperature to be used in 1D simulations +! +! USE dimphy, ONLY : klon +! +! INTEGER, INTENT(IN) :: knon ! nomber of points on compressed grid +! REAL, DIMENSION(klon), INTENT(OUT) :: sst_out ! tsurf used to force the single-column model +! +! INTEGER :: i +! COMMON defined in lmdz1d.F: +! real ts_cur +! common /sst_forcing/ts_cur +! +! DO i = 1, knon +! sst_out(i) = ts_cur +! ENDDO +! +! END SUBROUTINE read_tsurf1d +! +! +!************************************************************************ +END MODULE ocean_forced_mod + + + + + + Index: LMDZ6/trunk/libf/phylmdiso/pbl_surface_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/pbl_surface_mod.F90 (revision 5943) +++ LMDZ6/trunk/libf/phylmdiso/pbl_surface_mod.F90 (revision 5943) @@ -0,0 +1,4699 @@ +! +! $Id: pbl_surface_mod.F90 5927 2025-12-12 16:26:10Z snguyen $ +! +MODULE pbl_surface_mod +! +! Planetary Boundary Layer and Surface module +! +! This module manages the calculation of turbulent diffusion in the boundary layer +! and all interactions towards the differents sub-surfaces. +! +! + USE dimphy + USE mod_phys_lmdz_para, ONLY : mpi_size + USE mod_grid_phy_lmdz, ONLY : klon_glo + USE ioipsl + USE surface_data, ONLY : type_ocean, ok_veget, landice_opt, iflag_leads + USE surf_land_mod, ONLY : surf_land + USE surf_landice_mod, ONLY : surf_landice + USE surf_ocean_mod, ONLY : surf_ocean + USE surf_seaice_mod, ONLY : surf_seaice + USE cpl_mod, ONLY : gath2cpl + USE climb_hq_mod, ONLY : climb_hq_down, climb_hq_up + USE climb_qbs_mod, ONLY : climb_qbs_down, climb_qbs_up + USE climb_wind_mod, ONLY : climb_wind_down, climb_wind_up + USE coef_diff_turb_mod, ONLY : coef_diff_turb + USE lmdz_call_atke, ONLY : call_atke + USE ioipsl_getin_p_mod, ONLY : getin_p + USE cdrag_mod + USE stdlevvar_mod + USE wx_pbl_var_mod, ONLY : wx_pbl_init, wx_pbl_final, & + wx_pbl_prelim_0, wx_pbl_prelim_beta + USE wx_pbl_mod, ONLY : wx_pbl0_merge, wx_pbl_split, wx_pbl_dts_merge, & + wx_pbl_check, wx_pbl_dts_check, wx_evappot + USE config_ocean_skin_m, ONLY : activate_ocean_skin +#ifdef ISO + USE infotrac_phy, ONLY: niso,ntraciso=>ntiso + USE phys_local_var_mod, ONLY: Rsol !! SN soil isotope ratio for LMDZORISO +#endif + + IMPLICIT NONE + +! Declaration of variables saved in restart file + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: fder ! flux drift + !$OMP THREADPRIVATE(fder) +!GG + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: hice ! flux drift + !$OMP THREADPRIVATE(hice) + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: tice ! flux drift + !$OMP THREADPRIVATE(tice) + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: bilg_cumul ! flux drift + !$OMP THREADPRIVATE(bilg_cumul) +!GG + REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC, SAVE :: snow ! snow at surface + !$OMP THREADPRIVATE(snow) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: qsurf ! humidity at surface + !$OMP THREADPRIVATE(qsurf) + REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: ftsoil ! soil temperature + !$OMP THREADPRIVATE(ftsoil) + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: ydTs0, ydqs0 + ! nul forced temperature and humidity differences + !$OMP THREADPRIVATE(ydTs0, ydqs0) + +#ifdef ISO + REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: xtsnow ! snow at surface + !$OMP THREADPRIVATE(xtsnow) + REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: Rland_ice ! ice bucket bellow snowpack + !$OMP THREADPRIVATE(Rland_ice) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: Roce + !$OMP THREADPRIVATE(Roce) +#endif + + INTEGER, SAVE :: iflag_pbl_surface_t2m_bug + !$OMP THREADPRIVATE(iflag_pbl_surface_t2m_bug) + INTEGER, SAVE :: iflag_new_t2mq2m + !$OMP THREADPRIVATE(iflag_new_t2mq2m) + LOGICAL, SAVE :: ok_bug_zg_wk_pbl + !$OMP THREADPRIVATE(ok_bug_zg_wk_pbl) + + +!JYG< + REAL, SAVE, PROTECTED :: smallestreal + !$OMP THREADPRIVATE(smallestreal) + +!FC +! integer, save :: iflag_frein +! !$OMP THREADPRIVATE(iflag_frein) + +CONTAINS +! +!**************************************************************************************** +! +!GG +! SUBROUTINE pbl_surface_init(fder_rst, snow_rst, qsurf_rst, ftsoil_rst) + SUBROUTINE pbl_surface_init(fder_rst, snow_rst, qsurf_rst, ftsoil_rst, hice_rst, tice_rst, bilg_cumul_rst) +!GG + +! This routine should be called after the restart file has been read. +! This routine initialize the restart variables and does some validation tests +! for the index of the different surfaces and tests the choice of type of ocean. + + USE indice_sol_mod + USE print_control_mod, ONLY: lunout + USE ioipsl_getin_p_mod, ONLY : getin_p + USE dimsoil_mod_h, ONLY: nsoilmx + IMPLICIT NONE + +! Input variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(IN) :: fder_rst +!GG + REAL, DIMENSION(klon), INTENT(IN) :: hice_rst + REAL, DIMENSION(klon), INTENT(IN) :: tice_rst + REAL, DIMENSION(klon), INTENT(IN) :: bilg_cumul_rst +!GG + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: snow_rst + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: qsurf_rst + REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(IN) :: ftsoil_rst + +! Local variables +!**************************************************************************************** + INTEGER :: ierr + CHARACTER(len=80) :: abort_message + CHARACTER(len = 20) :: modname = 'pbl_surface_init' + +!**************************************************************************************** +! Initialize some module variables +!**************************************************************************************** + smallestreal = tiny(smallestreal) + +!**************************************************************************************** +! Allocate and initialize module variables with fields read from restart file. +! +!**************************************************************************************** + + ALLOCATE(fder(klon), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1) + +!GG + ALLOCATE(hice(klon), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init hice', 'pb in allocation',1) + + ALLOCATE(tice(klon), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init tice', 'pb in allocation',1) + + ALLOCATE(bilg_cumul(klon), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init bilg', 'pb in allocation',1) +!GG + + ALLOCATE(snow(klon,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(qsurf(klon,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(ftsoil(klon,nsoilmx,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(ydTs0(klon), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(ydqs0(klon), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1) + + fder(:) = fder_rst(:) +!GG + hice(:) = hice_rst(:) + tice(:) = tice_rst(:) + bilg_cumul(:) = bilg_cumul_rst(:) +!GG + snow(:,:) = snow_rst(:,:) + qsurf(:,:) = qsurf_rst(:,:) + ftsoil(:,:,:) = ftsoil_rst(:,:,:) + ydTs0(:) = 0. + ydqs0(:) = 0. + +!**************************************************************************************** +! Test for sub-surface indices +! +!**************************************************************************************** + IF (is_ter /= 1) THEN + WRITE(lunout,*)" *** Warning ***" + WRITE(lunout,*)" is_ter n'est pas le premier surface, is_ter = ",is_ter + WRITE(lunout,*)"or on doit commencer par les surfaces continentales" + abort_message="voir ci-dessus" + CALL abort_physic(modname,abort_message,1) + ENDIF + + IF ( is_oce > is_sic ) THEN + WRITE(lunout,*)' *** Warning ***' + WRITE(lunout,*)' Pour des raisons de sequencement dans le code' + WRITE(lunout,*)' l''ocean doit etre traite avant la banquise' + WRITE(lunout,*)' or is_oce = ',is_oce, '> is_sic = ',is_sic + abort_message='voir ci-dessus' + CALL abort_physic(modname,abort_message,1) + ENDIF + + IF ( is_lic > is_sic ) THEN + WRITE(lunout,*)' *** Warning ***' + WRITE(lunout,*)' Pour des raisons de sequencement dans le code' + WRITE(lunout,*)' la glace contineltalle doit etre traite avant la glace de mer' + WRITE(lunout,*)' or is_lic = ',is_lic, '> is_sic = ',is_sic + abort_message='voir ci-dessus' + CALL abort_physic(modname,abort_message,1) + ENDIF + +!**************************************************************************************** +! Validation of ocean mode +! +!**************************************************************************************** + + IF (type_ocean /= 'slab ' .AND. type_ocean /= 'force ' .AND. type_ocean /= 'couple') THEN + WRITE(lunout,*)' *** Warning ***' + WRITE(lunout,*)'Option couplage pour l''ocean = ', type_ocean + abort_message='option pour l''ocean non valable' + CALL abort_physic(modname,abort_message,1) + ENDIF + + iflag_pbl_surface_t2m_bug=0 + CALL getin_p('iflag_pbl_surface_t2m_bug',iflag_pbl_surface_t2m_bug) + WRITE(lunout,*) 'iflag_pbl_surface_t2m_bug=',iflag_pbl_surface_t2m_bug +!FC +! iflag_frein = 0 +! CALL getin_p('iflag_frein',iflag_frein) +! +!jyg< +!**************************************************************************************** +! Allocate variables for pbl splitting +! +!**************************************************************************************** + + CALL wx_pbl_init +!>jyg + + END SUBROUTINE pbl_surface_init + +#ifdef ISO + SUBROUTINE pbl_surface_init_iso(xtsnow_rst,Rland_ice_rst,Rsol_rst) + +! This routine should be called after the restart file has been read. +! This routine initialize the restart variables and does some validation tests +! for the index of the different surfaces and tests the choice of type of ocean. + + USE indice_sol_mod + USE print_control_mod, ONLY: lunout +#ifdef ISOVERIF + USE isotopes_mod, ONLY: iso_eau,ridicule + USE isotopes_verif_mod +#endif + USE dimsoil_mod_h, ONLY: nsoilmx + IMPLICIT NONE + +! Input variables +!**************************************************************************************** + REAL, DIMENSION(niso,klon, nbsrf), INTENT(IN) :: xtsnow_rst + REAL, DIMENSION(niso,klon), INTENT(IN) :: Rland_ice_rst, Rsol_rst + +! Local variables +!**************************************************************************************** + INTEGER :: ierr + CHARACTER(len=80) :: abort_message + CHARACTER(len = 20) :: modname = 'pbl_surface_init' + INTEGER :: i,ixt + +!**************************************************************************************** +! Allocate and initialize module variables with fields read from restart file. +! +!**************************************************************************************** + + ALLOCATE(xtsnow(niso,klon,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(Rland_ice(niso,klon), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(Roce(niso,klon), stat=ierr) + IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1) + + xtsnow(:,:,:) = xtsnow_rst(:,:,:) + Rland_ice(:,:) = Rland_ice_rst(:,:) + Rsol(:,:) = Rsol_rst(:,:) + Roce(:,:) = 0.0 + +#ifdef ISOVERIF + IF (iso_eau >= 0) THEN + CALL iso_verif_egalite_vect2D( & + & xtsnow,snow, & + & 'pbl_surface_mod 286',niso,klon,nbsrf) + DO i=1,klon + IF (iso_eau >= 0) THEN + CALL iso_verif_egalite(Rland_ice(iso_eau,i),1.0, & + & 'pbl_surf_mod 290') + CALL iso_verif_egalite(Rsol(iso_eau,i),1.0, & + & 'pbl_surf_mod 292') + ENDIF + ENDDO + ENDIF +#endif + + END SUBROUTINE pbl_surface_init_iso +#endif + +! +!**************************************************************************************** +! + + SUBROUTINE pbl_surface( & + dtime, date0, itap, jour, & + debut, lafin, & + rlon, rlat, rugoro, rmu0, & + !GG lwdown_m, cldt, & + lwdown_m, pphi, cldt, & + !GG + rain_f, snow_f, bs_f, solsw_m, solswfdiff_m, sollw_m, & + gustiness, & + t, q, qbs, u, v, & +!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012 +!! t_x, q_x, t_w, q_w, & + wake_dlt, wake_dlq, & + wake_cstar, wake_s, & +!!! + pplay, paprs, pctsrf, & + ts,SFRWL, alb_dir, alb_dif,ustar, u10m, v10m,wstar, & + cdragh, cdragm, zu1, zv1, & +!jyg< (26/09/2019) + beta, & +!>jyg + alb_dir_m, alb_dif_m, zxsens, zxevap, zxsnowerosion, & + icesub_lic, alb3_lic, runoff, snowhgt, qsnow, to_ice, sissnow, & + zxtsol, zxfluxlat, zt2m, qsat2m, zn2mout, & + d_t, d_q, d_qbs, d_u, d_v, d_t_diss, & +!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012 + d_t_w, d_q_w, & + d_t_x, d_q_x, & +!! d_wake_dlt,d_wake_dlq, & + zxsens_x, zxfluxlat_x,zxsens_w,zxfluxlat_w, & +!!! +!!! nrlmd le 13/06/2011 + delta_tsurf,wake_dens,cdragh_x,cdragh_w, & + cdragm_x,cdragm_w,kh,kh_x,kh_w, & +!!! + zcoefh, zcoefm, slab_wfbils, & + qsol, zq2m, s_pblh, s_plcl, & +!!! +!!! jyg le 08/02/2012 + s_pblh_x, s_plcl_x, s_pblh_w, s_plcl_w, & +!!! + s_capCL, s_oliqCL, s_cteiCL, s_pblT, & + s_therm, s_trmb1, s_trmb2, s_trmb3, & + zustar,zu10m, zv10m, fder_print, & + zxqsurf, delta_qsurf, & + rh2m, zxfluxu, zxfluxv, & + z0m, z0h, agesno, sollw, solsw, & + d_ts, evap, fluxlat, t2m, & + wfbils, wfevap, & + flux_t, flux_u, flux_v, & + dflux_t, dflux_q, zxsnow, & +!jyg< +!! zxfluxt, zxfluxq, q2m, flux_q, tke, & + zxfluxt, zxfluxq, zxfluxqbs, q2m, flux_q, flux_qbs, tke_x, eps_x, & +!>jyg +!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012 +!! tke_x, tke_w & + wake_dltke, & +!GG treedrg & + treedrg,hice ,tice, bilg_cumul, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, & + dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic , & +!GG +!FC +!AM heterogeneous continental sub-surfaces + tsurf_tersrf, tsoil_tersrf, qsurf_tersrf, tsurf_new_tersrf, & + cdragm_tersrf, cdragh_tersrf, & + swnet_tersrf, lwnet_tersrf, fluxsens_tersrf, fluxlat_tersrf & +!!! +#ifdef ISO + & ,xtrain_f,xtsnow_f,xt, & + & wake_dlxt,zxxtevap,xtevap, & + & d_xt,d_xt_w,d_xt_x, & + & xtsol,dflux_xt,zxxtsnow,zxfluxxt,flux_xt, & + & h1_diag,runoff_diag,xtrunoff_diag, & + & xtriverflow,xtcoastalflow & +#endif + & ) +!**************************************************************************************** +! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +! Objet: interface de "couche limite" (diffusion verticale) +! +!AA REM: +!AA----- +!AA Tout ce qui a trait au traceurs est dans phytrac maintenant +!AA pour l'instant le calcul de la couche limite pour les traceurs +!AA se fait avec cltrac et ne tient pas compte de la differentiation +!AA des sous-fraction de sol. +!AA REM bis : +!AA---------- +!AA Pour pouvoir extraire les coefficient d'echanges et le vent +!AA dans la premiere couche, 3 champs supplementaires ont ete crees +!AA zcoefh, zu1 et zv1. Pour l'instant nous avons moyenne les valeurs +!AA de ces trois champs sur les 4 subsurfaces du modele. Dans l'avenir +!AA si les informations des subsurfaces doivent etre prises en compte +!AA il faudra sortir ces memes champs en leur ajoutant une dimension, +!AA c'est a dire nbsrf (nbre de subsurface). +! +! Arguments: +! +! dtime----input-R- interval du temps (secondes) +! itap-----input-I- numero du pas de temps +! date0----input-R- jour initial +! t--------input-R- temperature (K) +! q--------input-R- vapeur d'eau (kg/kg) +! u--------input-R- vitesse u +! v--------input-R- vitesse v +! wake_dlt-input-R- temperatre difference between (w) and (x) (K) +! wake_dlq-input-R- humidity difference between (w) and (x) (kg/kg) +!wake_cstar-input-R- wake gust front speed (m/s) +! wake_s---input-R- wake fractionnal area +! ts-------input-R- temperature du sol (en Kelvin) +! paprs----input-R- pression a intercouche (Pa) +! pplay----input-R- pression au milieu de couche (Pa) +! rlat-----input-R- latitude en degree +! z0m, z0h ----input-R- longeur de rugosite (en m) +! Martin +! cldt-----input-R- total cloud fraction +! Martin +!GG +! pphi-----input-R- geopotentiel de chaque couche (g z) (reference sol) +!GG +! +! d_t------output-R- le changement pour "t" +! d_q------output-R- le changement pour "q" +! d_u------output-R- le changement pour "u" +! d_v------output-R- le changement pour "v" +! d_ts-----output-R- le changement pour "ts" +! flux_t---output-R- flux de chaleur sensible (CpT) J/m**2/s (W/m**2) +! (orientation positive vers le bas) +! tke_x---input/output-R- tke in the (x) region (kg/m**2/s) +! wake_dltke-input/output-R- tke difference between (w) and (x) (kg/m**2/s) +! flux_q---output-R- flux de vapeur d'eau (kg/m**2/s) +! flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal +! flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal +! dflux_t--output-R- derive du flux sensible +! dflux_q--output-R- derive du flux latent +! zu1------output-R- le vent dans la premiere couche +! zv1------output-R- le vent dans la premiere couche +! trmb1----output-R- deep_cape +! trmb2----output-R- inhibition +! trmb3----output-R- Point Omega +! cteiCL---output-R- Critere d'instab d'entrainmt des nuages de CL +! plcl-----output-R- Niveau de condensation +! pblh-----output-R- HCL +! pblT-----output-R- T au nveau HCL +! treedrg--output-R- tree drag (m) +! qsurf_tersrf--output-R- surface specific humidity of continental sub-surfaces +! cdragm_tersrf--output-R- momentum drag coefficient of continental sub-surfaces +! cdragh_tersrf--output-R- heat drag coefficient of continental sub-surfaces +! tsurf_new_tersrf--output-R- surface temperature of continental sub-surfaces +! swnet_tersrf--output-R- net shortwave radiation of continental sub-surfaces +! lwnet_tersrf--output-R- net longwave radiation of continental sub-surfaces +! fluxsens_tersrf--output-R- sensible heat flux of continental sub-surfaces +! fluxlat_tersrf--output-R- latent heat flux of continental sub-surfaces + + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, carbon_cycle_tr, level_coupling_esm + USE carbon_cycle_mod, ONLY : co2_send, nbcf_out, fields_out, yfields_out, cfname_out + USE hbtm_mod, ONLY : hbtm + USE indice_sol_mod + USE time_phylmdz_mod, ONLY : day_ini,annee_ref,itau_phy + USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat, grid1dto2d_glo + USE print_control_mod, ONLY : prt_level,lunout +#ifdef ISO + USE isotopes_mod, ONLY: Rdefault,iso_eau +#ifdef ISOVERIF + USE isotopes_verif_mod +#endif +#ifdef ISOTRAC + USE isotrac_mod, ONLY: index_iso +#endif +#endif + USE dimpft_mod_h + USE flux_arp_mod_h + USE compbl_mod_h + USE yoethf_mod_h + USE clesphys_mod_h + USE ioipsl_getin_p_mod, ONLY : getin_p + USE phys_state_var_mod, ONLY : ds_ns, dt_ns, delta_sst, delta_sal, dter, & + dser, dt_ds, zsig, zmea, & + frac_tersrf, z0m_tersrf, ratio_z0m_z0h_tersrf, albedo_tersrf !AM + USE phys_output_var_mod, ONLY : tkt, tks, taur, sss + USE lmdz_blowing_snow_ini, ONLY : zeta_bs + USE wxios_mod, ONLY : missing_val_xios => missing_val, using_xios + USE netcdf, ONLY : missing_val_netcdf => nf90_fill_real + USE dimsoil_mod_h, ONLY : nsoilmx + USE surf_param_mod, ONLY : eff_surf_param !AM + + USE yomcst_mod_h + + IMPLICIT NONE + + INCLUDE "FCTTRE.h" +!FC + +!**************************************************************************************** + REAL, INTENT(IN) :: dtime ! time interval (s) + REAL, INTENT(IN) :: date0 ! initial day + INTEGER, INTENT(IN) :: itap ! time step + INTEGER, INTENT(IN) :: jour ! current day of the year + LOGICAL, INTENT(IN) :: debut ! true if first run step + LOGICAL, INTENT(IN) :: lafin ! true if last run step + REAL, DIMENSION(klon), INTENT(IN) :: rlon ! longitudes in degrees + REAL, DIMENSION(klon), INTENT(IN) :: rlat ! latitudes in degrees + REAL, DIMENSION(klon), INTENT(IN) :: rugoro ! rugosity length + REAL, DIMENSION(klon), INTENT(IN) :: rmu0 ! cosine of solar zenith angle + REAL, DIMENSION(klon), INTENT(IN) :: rain_f ! rain fall + REAL, DIMENSION(klon), INTENT(IN) :: snow_f ! snow fall + REAL, DIMENSION(klon), INTENT(IN) :: bs_f ! blowing snow fall + REAL, DIMENSION(klon), INTENT(IN) :: solsw_m ! net shortwave radiation at mean surface + REAL, DIMENSION(klon), INTENT(IN) :: solswfdiff_m ! diffuse fraction fordownward shortwave radiation at mean surface + REAL, DIMENSION(klon), INTENT(IN) :: sollw_m ! net longwave radiation at mean surface + REAL, DIMENSION(klon,klev), INTENT(IN) :: t ! temperature (K) + REAL, DIMENSION(klon,klev), INTENT(IN) :: q ! water vapour (kg/kg) + REAL, DIMENSION(klon,klev), INTENT(IN) :: qbs ! blowing snow specific content (kg/kg) + REAL, DIMENSION(klon,klev), INTENT(IN) :: u ! u speed + REAL, DIMENSION(klon,klev), INTENT(IN) :: v ! v speed + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay ! mid-layer pression (Pa) + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! pression between layers (Pa) + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: pctsrf ! sub-surface fraction +! Martin + REAL, DIMENSION(klon), INTENT(IN) :: lwdown_m ! downward longwave radiation at mean s + REAL, DIMENSION(klon), INTENT(IN) :: gustiness ! gustiness + +!GG + REAL, DIMENSION(klon,klev), INTENT(IN) :: pphi ! geopotential (m2/s2) +!GG + REAL, DIMENSION(klon), INTENT(IN) :: cldt ! total cloud + +#ifdef ISO + REAL, DIMENSION(ntraciso,klon,klev), INTENT(IN) :: xt ! water vapour (kg/kg) + REAL, DIMENSION(ntraciso,klon), INTENT(IN) :: xtrain_f ! rain fall + REAL, DIMENSION(ntraciso,klon), INTENT(IN) :: xtsnow_f ! snow fall +#endif + +!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012 +!! REAL, DIMENSION(klon,klev), INTENT(IN) :: t_x ! Temp\'erature hors poche froide +!! REAL, DIMENSION(klon,klev), INTENT(IN) :: t_w ! Temp\'erature dans la poches froide +!! REAL, DIMENSION(klon,klev), INTENT(IN) :: q_x ! +!! REAL, DIMENSION(klon,klev), INTENT(IN) :: q_w ! Pareil pour l'humidit\'e + REAL, DIMENSION(klon,klev), INTENT(IN) :: wake_dlt !temperature difference between (w) and (x) (K) + REAL, DIMENSION(klon,klev), INTENT(IN) :: wake_dlq !humidity difference between (w) and (x) (K) + REAL, DIMENSION(klon), INTENT(IN) :: wake_s ! Fraction de poches froides + REAL, DIMENSION(klon), INTENT(IN) :: wake_cstar! Vitesse d'expansion des poches froides + REAL, DIMENSION(klon), INTENT(IN) :: wake_dens +!!! +#ifdef ISO + REAL, DIMENSION(ntraciso,klon,klev), INTENT(IN) :: wake_dlxt +#endif +! Input/Output variables +!**************************************************************************************** +!jyg< + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: beta ! Aridity factor +!>jyg + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: ts ! temperature at surface (K) + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: delta_tsurf !surface temperature difference between + !wake and off-wake regions +!albedo SB >>> + REAL, DIMENSIOn(6),intent(in) :: SFRWL + REAL, DIMENSION(klon, nsw, nbsrf), INTENT(INOUT) :: alb_dir,alb_dif +!albedo SB <<< +!jyg Pourquoi ustar et wstar sont-elles INOUT ? + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: ustar ! u* (m/s) + REAL, DIMENSION(klon, nbsrf+1), INTENT(INOUT) :: wstar ! w* (m/s) + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: u10m ! u speed at 10m + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: v10m ! v speed at 10m +!jyg< +!! REAL, DIMENSION(klon, klev+1, nbsrf+1), INTENT(INOUT) :: tke + REAL, DIMENSION(klon, klev+1, nbsrf+1), INTENT(INOUT) :: tke_x +!>jyg + +!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012 + REAL, DIMENSION(klon, klev+1, nbsrf+1), INTENT(INOUT) :: wake_dltke ! TKE_w - TKE_x +!!! + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(OUT) :: eps_x ! TKE dissipation rate + + REAL, DIMENSION(klon), INTENT(OUT) :: cdragh ! drag coefficient for T and Q + REAL, DIMENSION(klon), INTENT(OUT) :: cdragm ! drag coefficient for wind + REAL, DIMENSION(klon), INTENT(OUT) :: zu1 ! u wind speed in first layer + REAL, DIMENSION(klon), INTENT(OUT) :: zv1 ! v wind speed in first layer +!albedo SB >>> + REAL, DIMENSION(klon, nsw), INTENT(OUT) :: alb_dir_m,alb_dif_m +!albedo SB <<< + ! Martin + REAL, DIMENSION(klon), INTENT(OUT) :: alb3_lic + ! Martin + REAL, DIMENSION(klon), INTENT(OUT) :: zxsens ! sensible heat flux at surface with inversed sign + ! (=> positive sign upwards) + REAL, DIMENSION(klon), INTENT(OUT) :: zxevap ! water vapour flux at surface, positiv upwards + REAL, DIMENSION(klon), INTENT(OUT) :: zxsnowerosion ! blowing snow flux at surface + REAL, DIMENSION(klon), INTENT(OUT) :: icesub_lic ! ice (no snow!) sublimation over ice sheet + REAL, DIMENSION(klon), INTENT(OUT) :: zxtsol ! temperature at surface, mean for each grid point +!!! jyg le ??? + REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_t_w ! ! + REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_q_w ! ! Tendances dans les poches + REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_t_x ! ! + REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_q_x ! ! Tendances hors des poches +!!! jyg + REAL, DIMENSION(klon), INTENT(OUT) :: zxfluxlat ! latent flux, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: zt2m ! temperature at 2m, mean for each grid point + INTEGER, DIMENSION(klon, 6), INTENT(OUT) :: zn2mout ! number of times the 2m temperature is out of the [tsol,temp] + REAL, DIMENSION(klon), INTENT(OUT) :: qsat2m + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_t ! change in temperature + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_t_diss ! change in temperature + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_q ! change in water vapour + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_u ! change in u speed + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_v ! change in v speed + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_qbs ! change in blowing snow specific content + + + REAL, INTENT(OUT):: zcoefh(:, :, :) ! (klon, klev, nbsrf + 1) + ! coef for turbulent diffusion of T and Q, mean for each grid point + + REAL, INTENT(OUT):: zcoefm(:, :, :) ! (klon, klev, nbsrf + 1) + ! coef for turbulent diffusion of U and V (?), mean for each grid point +#ifdef ISO + REAL, DIMENSION(ntraciso,klon), INTENT(OUT) :: zxxtevap ! water vapour flux at surface, positiv upwards + REAL, DIMENSION(ntraciso,klon, klev), INTENT(OUT) :: d_xt ! change in water vapour + REAL, DIMENSION(klon), INTENT(OUT) :: runoff_diag + REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtrunoff_diag + REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtriverflow ! PRSN LMDZORISO variables + REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtcoastalflow ! PRSN Fin + REAL, DIMENSION(ntraciso,klon,klev), INTENT(OUT) :: d_xt_w + REAL, DIMENSION(ntraciso,klon,klev), INTENT(OUT) :: d_xt_x +#endif + + + +!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012 + REAL, DIMENSION(klon), INTENT(OUT) :: zxsens_x ! Flux sensible hors poche + REAL, DIMENSION(klon), INTENT(OUT) :: zxsens_w ! Flux sensible dans la poche + REAL, DIMENSION(klon), INTENT(OUT) :: zxfluxlat_x! Flux latent hors poche + REAL, DIMENSION(klon), INTENT(OUT) :: zxfluxlat_w! Flux latent dans la poche +!! REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_wake_dlt +!! REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_wake_dlq + +! Output only for diagnostics + REAL, DIMENSION(klon), INTENT(OUT) :: cdragh_x + REAL, DIMENSION(klon), INTENT(OUT) :: cdragh_w + REAL, DIMENSION(klon), INTENT(OUT) :: cdragm_x + REAL, DIMENSION(klon), INTENT(OUT) :: cdragm_w + REAL, DIMENSION(klon), INTENT(OUT) :: kh + REAL, DIMENSION(klon), INTENT(OUT) :: kh_x + REAL, DIMENSION(klon), INTENT(OUT) :: kh_w +!!! + REAL, DIMENSION(klon), INTENT(OUT) :: slab_wfbils! heat balance at surface only for slab at ocean points + REAL, DIMENSION(klon), INTENT(OUT) :: qsol ! water height in the soil (mm) + REAL, DIMENSION(klon), INTENT(OUT) :: zq2m ! water vapour at 2m, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: s_pblh ! height of the planetary boundary layer(HPBL) +!!! jyg le 08/02/2012 + REAL, DIMENSION(klon), INTENT(OUT) :: s_pblh_x ! height of the PBL in the off-wake region + REAL, DIMENSION(klon), INTENT(OUT) :: s_pblh_w ! height of the PBL in the wake region +!!! + REAL, DIMENSION(klon), INTENT(OUT) :: s_plcl ! condensation level +!!! jyg le 08/02/2012 + REAL, DIMENSION(klon), INTENT(OUT) :: s_plcl_x ! condensation level in the off-wake region + REAL, DIMENSION(klon), INTENT(OUT) :: s_plcl_w ! condensation level in the wake region +!!! + REAL, DIMENSION(klon), INTENT(OUT) :: s_capCL ! CAPE of PBL + REAL, DIMENSION(klon), INTENT(OUT) :: s_oliqCL ! liquid water intergral of PBL + REAL, DIMENSION(klon), INTENT(OUT) :: s_cteiCL ! cloud top instab. crit. of PBL + REAL, DIMENSION(klon), INTENT(OUT) :: s_pblT ! temperature at PBLH + REAL, DIMENSION(klon), INTENT(OUT) :: s_therm ! thermal virtual temperature excess + REAL, DIMENSION(klon), INTENT(OUT) :: s_trmb1 ! deep cape, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: s_trmb2 ! inhibition, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: s_trmb3 ! point Omega, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: zustar ! u* + REAL, DIMENSION(klon), INTENT(OUT) :: zu10m ! u speed at 10m, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: zv10m ! v speed at 10m, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: fder_print ! fder for printing (=fder(i) + dflux_t(i) + dflux_q(i)) + REAL, DIMENSION(klon), INTENT(OUT) :: zxqsurf ! humidity at surface, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: delta_qsurf! humidity difference at surface, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: rh2m ! relative humidity at 2m + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxu ! u wind tension, mean for each grid point + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxv ! v wind tension, mean for each grid point + REAL, DIMENSION(klon, nbsrf+1), INTENT(INOUT) :: z0m,z0h ! rugosity length (m) + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: agesno ! age of snow at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: solsw ! net shortwave radiation at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: sollw ! net longwave radiation at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: d_ts ! change in temperature at surface + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: evap ! evaporation at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: fluxlat ! latent flux + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: t2m ! temperature at 2 meter height + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: wfbils ! heat balance at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: wfevap ! water balance (evap) at surface weighted by srf + REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_t ! sensible heat flux (CpT) J/m**2/s (W/m**2) + ! positve orientation downwards + REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_u ! u wind tension (kg m/s)/(m**2 s) or Pascal + REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_v ! v wind tension (kg m/s)/(m**2 s) or Pascal +!FC + REAL, DIMENSION(klon, klev, nbsrf), INTENT(INOUT) :: treedrg ! tree drag (m) +!AM heterogeneous continental sub-surfaces + REAL, DIMENSION(klon, nbtersrf), INTENT(INOUT) :: tsurf_tersrf ! surface temperature of continental sub-surfaces (K) + REAL, DIMENSION(klon, nbtersrf), INTENT(INOUT) :: qsurf_tersrf ! surface specific humidity of continental sub-surfaces (kg/kg) + REAL, DIMENSION(klon, nbtersrf), INTENT(INOUT) :: tsurf_new_tersrf ! surface temperature of continental sub-surfaces (K) + REAL, DIMENSION(klon, nbtersrf), INTENT(INOUT) :: cdragm_tersrf ! momentum drag coefficient of continental sub-surfaces (-) + REAL, DIMENSION(klon, nbtersrf), INTENT(INOUT) :: cdragh_tersrf ! heat drag coefficient of continental sub-surfaces (-) + REAL, DIMENSION(klon, nbtersrf), INTENT(INOUT) :: swnet_tersrf ! net shortwave radiation of continental sub-surfaces (W/m2) + REAL, DIMENSION(klon, nbtersrf), INTENT(INOUT) :: lwnet_tersrf ! net longwave radiation of continental sub-surfaces (W/m2) + REAL, DIMENSION(klon, nbtersrf), INTENT(INOUT) :: fluxsens_tersrf ! sensible heat flux of continental sub-surfaces (W/m2) + REAL, DIMENSION(klon, nbtersrf), INTENT(INOUT) :: fluxlat_tersrf ! latent heat flux of continental sub-surfaces (W/m2) + REAL, DIMENSION(klon, nsoilmx, nbtersrf), INTENT(INOUT) :: tsoil_tersrf ! soil temperature of continental sub-surfaces (K) +#ifdef ISO + REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtsol ! water height in the soil (mm) + REAL, DIMENSION(ntraciso,klon, nbsrf) :: xtevap ! evaporation at surface + REAL, DIMENSION(klon), INTENT(OUT) :: h1_diag ! just diagnostic, not useful +#endif + + +! Output not needed + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_t ! change of sensible heat flux + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_q ! change of water vapour flux + REAL, DIMENSION(klon), INTENT(OUT) :: zxsnow ! snow at surface, mean for each grid point + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxt ! sensible heat flux, mean for each grid point + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxq ! water vapour flux, mean for each grid point + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxqbs ! blowing snow flux, mean for each grid point + REAL, DIMENSION(klon, nbsrf),INTENT(OUT) :: q2m ! water vapour at 2 meter height + REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_q ! water vapour flux(latent flux) (kg/m**2/s) + REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_qbs ! blowind snow vertical flux (kg/m**2 + +#ifdef ISO + REAL, DIMENSION(ntraciso,klon), INTENT(OUT) :: dflux_xt ! change of water vapour flux + REAL, DIMENSION(niso,klon), INTENT(OUT) :: zxxtsnow ! snow at surface, mean for each grid point + REAL, DIMENSION(ntraciso,klon, klev), INTENT(OUT) :: zxfluxxt ! water vapour flux, mean for each grid point + REAL, DIMENSION(ntraciso,klon, klev, nbsrf), INTENT(OUT) :: flux_xt ! water vapour flux(latent flux) (kg/m**2/s) +#endif + +! Martin +! inlandsis + REAL, DIMENSION(klon), INTENT(OUT) :: qsnow ! snow water content + REAL, DIMENSION(klon), INTENT(OUT) :: snowhgt ! snow height + REAL, DIMENSION(klon), INTENT(OUT) :: to_ice ! snow passed to ice + REAL, DIMENSION(klon), INTENT(OUT) :: sissnow ! snow in snow model + REAL, DIMENSION(klon), INTENT(OUT) :: runoff ! runoff on land ice +! Martin +!GG + REAL, DIMENSION(klon), INTENT(INOUT) :: hice ! hice + REAL, DIMENSION(klon), INTENT(INOUT) :: tice ! tice + REAL, DIMENSION(klon), INTENT(INOUT) :: bilg_cumul ! flux cumulated + REAL, DIMENSION(klon), INTENT(INOUT) :: fcds + REAL, DIMENSION(klon), INTENT(INOUT) :: fcdi + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_basal_growth + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_basal_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_top_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_snow2sic + REAL, DIMENSION(klon), INTENT(INOUT) :: dtice_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dtice_snow2sic +!GG + +! Local variables with attribute SAVE +!**************************************************************************************** + INTEGER, SAVE :: nhoridbg, nidbg ! variables for IOIPSL +!$OMP THREADPRIVATE(nhoridbg, nidbg) + LOGICAL, SAVE :: debugindex=.FALSE. +!$OMP THREADPRIVATE(debugindex) + LOGICAL, SAVE :: first_call=.TRUE. +!$OMP THREADPRIVATE(first_call) + CHARACTER(len=8), DIMENSION(nbsrf), SAVE :: cl_surf +!$OMP THREADPRIVATE(cl_surf) + REAL, SAVE :: beta_land ! beta for wx_dts +!$OMP THREADPRIVATE(beta_land) + +! Other local variables +!**************************************************************************************** +! >> PC + INTEGER :: ierr + INTEGER :: n +! << PC + INTEGER :: iflag_split, iflag_split_ref + INTEGER :: i, k, nsrf + INTEGER :: knon, j + INTEGER :: idayref + INTEGER , DIMENSION(klon) :: ni + REAL :: yt1_new + REAL :: zx_alf1, zx_alf2 !valeur ambiante par extrapola + REAL :: amn, amx + REAL :: f1 ! fraction de longeurs visibles parmi tout SW intervalle + REAL, DIMENSION(klon) :: r_co2_ppm ! taux CO2 atmosphere + REAL, DIMENSION(klon) :: yts, yz0m, yz0h, ypct + REAL, DIMENSION(klon) :: yz0h_old +!albedo SB >>> + REAL, DIMENSION(klon) :: yalb,yalb_vis +!albedo SB <<< + REAL, DIMENSION(klon) :: yt1, yq1, yu1, yv1, yqbs1 + REAL, DIMENSION(klon) :: yqa + REAL, DIMENSION(klon) :: ysnow, yqsurf, yagesno, yqsol + REAL, DIMENSION(klon) :: yrain_f, ysnow_f, ybs_f +#ifdef ISO + REAL, DIMENSION(ntraciso,klon) :: yxt1 + REAL, DIMENSION(niso,klon) :: yxtsnow, yxtsol + REAL, DIMENSION(ntraciso,klon) :: yxtrain_f, yxtsnow_f + REAL, DIMENSION(klon) :: yrunoff_diag + REAL, DIMENSION(niso,klon) :: yxtrunoff_diag + REAL, DIMENSION(niso,klon) :: yRland_ice + REAL, DIMENSION(niso,klon) :: yxtriverflow + REAL, DIMENSION(niso,klon) :: yxtcoastalflow + REAL, DIMENSION(niso,klon) :: yRsol +#endif + REAL, DIMENSION(klon) :: ysolsw, ysollw + REAL, DIMENSION(klon) :: yfder + REAL, DIMENSION(klon) :: yrugoro + REAL, DIMENSION(klon) :: yfluxlat + REAL, DIMENSION(klon) :: yfluxbs + REAL, DIMENSION(klon) :: y_d_ts + REAL, DIMENSION(klon) :: y_flux_t1, y_flux_q1 + REAL, DIMENSION(klon) :: y_dflux_t, y_dflux_q +#ifdef ISO + REAL, DIMENSION(ntraciso,klon) :: y_flux_xt1 + REAL, DIMENSION(ntraciso,klon) :: y_dflux_xt +#endif + REAL, DIMENSION(klon) :: y_flux_u1, y_flux_v1 + REAL, DIMENSION(klon) :: y_flux_bs, y_flux0 + REAL, DIMENSION(klon) :: yt2m, yq2m, yu10m + INTEGER, DIMENSION(klon, nbsrf, 6) :: yn2mout, yn2mout_x, yn2mout_w + INTEGER, DIMENSION(klon, nbsrf, 6) :: n2mout, n2mout_x, n2mout_w + REAL, DIMENSION(klon) :: yustar + REAL, DIMENSION(klon) :: ywstar + REAL, DIMENSION(klon) :: ywindsp + REAL, DIMENSION(klon) :: yt10m, yq10m + REAL, DIMENSION(klon) :: ypblh + REAL, DIMENSION(klon) :: ylcl + REAL, DIMENSION(klon) :: ycapCL + REAL, DIMENSION(klon) :: yoliqCL + REAL, DIMENSION(klon) :: ycteiCL + REAL, DIMENSION(klon) :: ypblT + REAL, DIMENSION(klon) :: ytherm + REAL, DIMENSION(klon) :: ytrmb1 + REAL, DIMENSION(klon) :: ytrmb2 + REAL, DIMENSION(klon) :: ytrmb3 + REAL, DIMENSION(klon) :: uzon, vmer + REAL, DIMENSION(klon) :: tair1, qair1, tairsol + REAL, DIMENSION(klon) :: psfce, patm + REAL, DIMENSION(klon) :: qairsol, zgeo1, speed, zri1, pref !speed, zri1, pref, added by Fuxing WANG, 04/03/2015 + REAL, DIMENSION(klon) :: yz0h_oupas + REAL, DIMENSION(klon) :: yfluxsens + REAL, DIMENSION(klon) :: AcoefH_0, AcoefQ_0, BcoefH_0, BcoefQ_0 + REAL, DIMENSION(klon) :: AcoefH, AcoefQ, BcoefH, BcoefQ +#ifdef ISO + REAL, DIMENSION(ntraciso,klon) :: AcoefXT, BcoefXT +#endif + REAL, DIMENSION(klon) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon) :: AcoefQBS, BcoefQBS + REAL, DIMENSION(klon) :: ypsref + REAL, DIMENSION(klon) :: yevap, yevap_pot, ytsurf_new, yalb3_new, yicesub_lic +!albedo SB >>> + REAL, DIMENSION(klon,nsw) :: yalb_dir_new, yalb_dif_new +!albedo SB <<< + REAL, DIMENSION(klon) :: ztsol + REAL, DIMENSION(klon) :: meansqT ! mean square deviation of subsurface temperatures + REAL, DIMENSION(klon) :: alb_m ! mean albedo for whole SW interval + REAL, DIMENSION(klon,klev) :: y_d_t, y_d_q, y_d_t_diss, y_d_qbs + REAL, DIMENSION(klon,klev) :: y_d_u, y_d_v + REAL, DIMENSION(klon,klev) :: y_flux_t, y_flux_q, y_flux_qbs + REAL, DIMENSION(klon,klev) :: y_flux_u, y_flux_v + REAL, DIMENSION(klon,klev) :: ycoefh,ycoefm,ycoefq,ycoefqbs + REAL, DIMENSION(klon) :: ycdragh, ycdragq, ycdragm + REAL, DIMENSION(klon,klev) :: yu, yv + REAL, DIMENSION(klon,klev) :: yt, yq, yqbs +#ifdef ISO + REAL, DIMENSION(ntraciso,klon) :: yxtevap + REAL, DIMENSION(ntraciso,klon,klev) :: y_d_xt + REAL, DIMENSION(ntraciso,klon,klev) :: y_flux_xt + REAL, DIMENSION(ntraciso,klon,klev) :: yxt +#endif + REAL, DIMENSION(klon,klev) :: ypplay, ydelp + REAL, DIMENSION(klon,klev) :: delp + REAL, DIMENSION(klon,klev+1) :: ypaprs + REAL, DIMENSION(klon,klev+1) :: ytke, yeps + REAL, DIMENSION(klon,nsoilmx) :: ytsoil +!FC + REAL, DIMENSION(klon,nvm_lmdz) :: yveget + REAL, DIMENSION(klon,nvm_lmdz) :: ylai + REAL, DIMENSION(klon,nvm_lmdz) :: yheight + REAL, DIMENSION(klon,klev) :: y_d_u_frein + REAL, DIMENSION(klon,klev) :: y_d_v_frein + REAL, DIMENSION(klon,klev) :: y_treedrg +!FC + + CHARACTER(len=80) :: abort_message + CHARACTER(len=20) :: modname = 'pbl_surface' + LOGICAL, PARAMETER :: zxli=.FALSE. ! utiliser un jeu de fonctions simples + LOGICAL, PARAMETER :: check=.FALSE. + +!!! nrlmd le 02/05/2011 +!!! jyg le 07/02/2012 + REAL, DIMENSION(klon) :: ywake_s, ywake_cstar, ywake_dens +!!! + REAL, DIMENSION(klon,klev+1) :: ytke_x, ytke_w, yeps_x, yeps_w + REAL, DIMENSION(klon,klev+1) :: ywake_dltke + REAL, DIMENSION(klon,klev) :: yu_x, yv_x, yu_w, yv_w + REAL, DIMENSION(klon,klev) :: yt_x, yq_x, yt_w, yq_w + REAL, DIMENSION(klon,klev) :: ycoefh_x, ycoefm_x, ycoefh_w, ycoefm_w + REAL, DIMENSION(klon,klev) :: ycoefq_x, ycoefq_w + REAL, DIMENSION(klon) :: ycdragh_x, ycdragh_w, ycdragq_x, ycdragq_w + REAL, DIMENSION(klon) :: ycdragm_x, ycdragm_w + REAL, DIMENSION(klon) :: AcoefH_x, AcoefQ_x, BcoefH_x, BcoefQ_x + REAL, DIMENSION(klon) :: AcoefH_w, AcoefQ_w, BcoefH_w, BcoefQ_w + REAL, DIMENSION(klon) :: AcoefU_x, AcoefV_x, BcoefU_x, BcoefV_x + REAL, DIMENSION(klon) :: AcoefU_w, AcoefV_w, BcoefU_w, BcoefV_w + REAL, DIMENSION(klon) :: y_flux_t1_x, y_flux_q1_x, y_flux_t1_w, y_flux_q1_w + REAL, DIMENSION(klon) :: y_flux_u1_x, y_flux_v1_x, y_flux_u1_w, y_flux_v1_w + REAL, DIMENSION(klon,klev) :: y_flux_t_x, y_flux_q_x, y_flux_t_w, y_flux_q_w + REAL, DIMENSION(klon,klev) :: y_flux_u_x, y_flux_v_x, y_flux_u_w, y_flux_v_w + REAL, DIMENSION(klon) :: yfluxlat_x, yfluxlat_w + REAL, DIMENSION(klon,klev) :: y_d_t_x, y_d_q_x, y_d_t_w, y_d_q_w + REAL, DIMENSION(klon,klev) :: y_d_t_diss_x, y_d_t_diss_w + REAL, DIMENSION(klon,klev) :: d_t_diss_x, d_t_diss_w + REAL, DIMENSION(klon,klev) :: y_d_u_x, y_d_v_x, y_d_u_w, y_d_v_w + REAL, DIMENSION(klon, klev, nbsrf) :: flux_t_x, flux_q_x, flux_t_w, flux_q_w + REAL, DIMENSION(klon, klev, nbsrf) :: flux_u_x, flux_v_x, flux_u_w, flux_v_w + REAL, DIMENSION(klon, nbsrf) :: fluxlat_x, fluxlat_w + REAL, DIMENSION(klon, klev) :: zxfluxt_x, zxfluxq_x, zxfluxt_w, zxfluxq_w + REAL, DIMENSION(klon, klev) :: zxfluxu_x, zxfluxv_x, zxfluxu_w, zxfluxv_w + REAL :: zx_qs_surf, zcor_surf, zdelta_surf +!jyg< + REAL, DIMENSION(klon) :: ybeta + REAL, DIMENSION(klon) :: ybeta_prev +!>jyg + REAL, DIMENSION(klon, klev) :: d_u_x + REAL, DIMENSION(klon, klev) :: d_u_w + REAL, DIMENSION(klon, klev) :: d_v_x + REAL, DIMENSION(klon, klev) :: d_v_w + + REAL, DIMENSION(klon,klev) :: CcoefH, CcoefQ, DcoefH, DcoefQ + REAL, DIMENSION(klon,klev) :: CcoefU, CcoefV, DcoefU, DcoefV + REAL, DIMENSION(klon,klev) :: CcoefQBS, DcoefQBS + REAL, DIMENSION(klon,klev) :: CcoefH_x, CcoefQ_x, DcoefH_x, DcoefQ_x + REAL, DIMENSION(klon,klev) :: CcoefH_w, CcoefQ_w, DcoefH_w, DcoefQ_w + REAL, DIMENSION(klon,klev) :: CcoefU_x, CcoefV_x, DcoefU_x, DcoefV_x + REAL, DIMENSION(klon,klev) :: CcoefU_w, CcoefV_w, DcoefU_w, DcoefV_w + REAL, DIMENSION(klon,klev) :: Kcoef_hq, Kcoef_m, gama_h, gama_q + REAL, DIMENSION(klon,klev) :: gama_qbs, Kcoef_qbs + REAL, DIMENSION(klon,klev) :: Kcoef_hq_x, Kcoef_m_x, gama_h_x, gama_q_x + REAL, DIMENSION(klon,klev) :: Kcoef_hq_w, Kcoef_m_w, gama_h_w, gama_q_w + REAL, DIMENSION(klon) :: alf_1, alf_2, alf_1_x, alf_2_x, alf_1_w, alf_2_w +#ifdef ISO + REAL, DIMENSION(ntraciso,klon,klev) :: yxt_x, yxt_w + REAL, DIMENSION(ntraciso,klon) :: y_flux_xt1_x , y_flux_xt1_w + REAL, DIMENSION(ntraciso,klon,klev) :: y_flux_xt_x,y_d_xt_x,zxfluxxt_x + REAL, DIMENSION(ntraciso,klon,klev) :: y_flux_xt_w,y_d_xt_w,zxfluxxt_w + REAL, DIMENSION(ntraciso,klon,klev,nbsrf) :: flux_xt_x, flux_xt_w + REAL, DIMENSION(ntraciso,klon) :: AcoefXT_x, BcoefXT_x + REAL, DIMENSION(ntraciso,klon) :: AcoefXT_w, BcoefXT_w + REAL, DIMENSION(ntraciso,klon,klev) :: CcoefXT, DcoefXT + REAL, DIMENSION(ntraciso,klon,klev) :: CcoefXT_x, DcoefXT_x + REAL, DIMENSION(ntraciso,klon,klev) :: CcoefXT_w, DcoefXT_w + REAL, DIMENSION(ntraciso,klon,klev) :: gama_xt,gama_xt_x,gama_xt_w +#endif +!!! +!!!jyg le 08/02/2012 + REAL, DIMENSION(klon, nbsrf) :: windsp +! + REAL, DIMENSION(klon, nbsrf) :: t2m_x + REAL, DIMENSION(klon, nbsrf) :: q2m_x + REAL, DIMENSION(klon) :: rh2m_x + REAL, DIMENSION(klon) :: qsat2m_x + REAL, DIMENSION(klon, nbsrf) :: u10m_x + REAL, DIMENSION(klon, nbsrf) :: v10m_x + REAL, DIMENSION(klon, nbsrf) :: ustar_x + REAL, DIMENSION(klon, nbsrf) :: wstar_x +! + REAL, DIMENSION(klon, nbsrf) :: pblh_x + REAL, DIMENSION(klon, nbsrf) :: plcl_x + REAL, DIMENSION(klon, nbsrf) :: capCL_x + REAL, DIMENSION(klon, nbsrf) :: oliqCL_x + REAL, DIMENSION(klon, nbsrf) :: cteiCL_x + REAL, DIMENSION(klon, nbsrf) :: pblt_x + REAL, DIMENSION(klon, nbsrf) :: therm_x + REAL, DIMENSION(klon, nbsrf) :: trmb1_x + REAL, DIMENSION(klon, nbsrf) :: trmb2_x + REAL, DIMENSION(klon, nbsrf) :: trmb3_x +! + REAL, DIMENSION(klon, nbsrf) :: t2m_w + REAL, DIMENSION(klon, nbsrf) :: q2m_w + REAL, DIMENSION(klon) :: rh2m_w + REAL, DIMENSION(klon) :: qsat2m_w + REAL, DIMENSION(klon, nbsrf) :: u10m_w + REAL, DIMENSION(klon, nbsrf) :: v10m_w + REAL, DIMENSION(klon, nbsrf) :: ustar_w + REAL, DIMENSION(klon, nbsrf) :: wstar_w +! + REAL, DIMENSION(klon, nbsrf) :: pblh_w + REAL, DIMENSION(klon, nbsrf) :: plcl_w + REAL, DIMENSION(klon, nbsrf) :: capCL_w + REAL, DIMENSION(klon, nbsrf) :: oliqCL_w + REAL, DIMENSION(klon, nbsrf) :: cteiCL_w + REAL, DIMENSION(klon, nbsrf) :: pblt_w + REAL, DIMENSION(klon, nbsrf) :: therm_w + REAL, DIMENSION(klon, nbsrf) :: trmb1_w + REAL, DIMENSION(klon, nbsrf) :: trmb2_w + REAL, DIMENSION(klon, nbsrf) :: trmb3_w +! + REAL, DIMENSION(klon) :: yt2m_x + REAL, DIMENSION(klon) :: yq2m_x + REAL, DIMENSION(klon) :: yt10m_x + REAL, DIMENSION(klon) :: yq10m_x + REAL, DIMENSION(klon) :: yu10m_x + REAL, DIMENSION(klon) :: yv10m_x + REAL, DIMENSION(klon) :: yustar_x + REAL, DIMENSION(klon) :: ywstar_x +! + REAL, DIMENSION(klon) :: ypblh_x + REAL, DIMENSION(klon) :: ylcl_x + REAL, DIMENSION(klon) :: ycapCL_x + REAL, DIMENSION(klon) :: yoliqCL_x + REAL, DIMENSION(klon) :: ycteiCL_x + REAL, DIMENSION(klon) :: ypblt_x + REAL, DIMENSION(klon) :: ytherm_x + REAL, DIMENSION(klon) :: ytrmb1_x + REAL, DIMENSION(klon) :: ytrmb2_x + REAL, DIMENSION(klon) :: ytrmb3_x +! + REAL, DIMENSION(klon) :: yt2m_w + REAL, DIMENSION(klon) :: yq2m_w + REAL, DIMENSION(klon) :: yt10m_w + REAL, DIMENSION(klon) :: yq10m_w + REAL, DIMENSION(klon) :: yu10m_w + REAL, DIMENSION(klon) :: yv10m_w + REAL, DIMENSION(klon) :: yustar_w + REAL, DIMENSION(klon) :: ywstar_w +! + REAL, DIMENSION(klon) :: ypblh_w + REAL, DIMENSION(klon) :: ylcl_w + REAL, DIMENSION(klon) :: ycapCL_w + REAL, DIMENSION(klon) :: yoliqCL_w + REAL, DIMENSION(klon) :: ycteiCL_w + REAL, DIMENSION(klon) :: ypblt_w + REAL, DIMENSION(klon) :: ytherm_w + REAL, DIMENSION(klon) :: ytrmb1_w + REAL, DIMENSION(klon) :: ytrmb2_w + REAL, DIMENSION(klon) :: ytrmb3_w +! + REAL, DIMENSION(klon) :: uzon_x, vmer_x, speed_x, zri1_x, pref_x !speed_x, zri1_x, pref_x, added by Fuxing WANG, 04/03/2015 + REAL, DIMENSION(klon) :: zgeo1_x, tair1_x, qair1_x, tairsol_x +! + REAL, DIMENSION(klon) :: uzon_w, vmer_w, speed_w, zri1_w, pref_w !speed_w, zri1_w, pref_w, added by Fuxing WANG, 04/03/2015 + REAL, DIMENSION(klon) :: zgeo1_w, tair1_w, qair1_w, tairsol_w + REAL, DIMENSION(klon) :: yus0, yvs0 + +!!! jyg le 25/03/2013 +!! Variables intermediaires pour le raccord des deux colonnes \`a la surface +!jyg< +!! REAL :: dd_Ch +!! REAL :: dd_Cm +!! REAL :: dd_Kh +!! REAL :: dd_Km +!! REAL :: dd_u +!! REAL :: dd_v +!! REAL :: dd_t +!! REAL :: dd_q +!! REAL :: dd_AH +!! REAL :: dd_AQ +!! REAL :: dd_AU +!! REAL :: dd_AV +!! REAL :: dd_BH +!! REAL :: dd_BQ +!! REAL :: dd_BU +!! REAL :: dd_BV +!! +!! REAL :: dd_KHp +!! REAL :: dd_KQp +!! REAL :: dd_KUp +!! REAL :: dd_KVp +!>jyg + +!!! +!!! nrlmd le 13/06/2011 + REAL, DIMENSION(klon) :: y_delta_flux_t1, y_delta_flux_q1, y_delta_flux_u1, y_delta_flux_v1 + REAL, DIMENSION(klon) :: y_delta_tsurf, y_delta_tsurf_new + REAL, DIMENSION(klon) :: delta_coef, tau_eq + REAL, DIMENSION(klon) :: HTphiT_b, dd_HTphiT, HTphiQ_b, dd_HTphiQ, HTRn_b, dd_HTRn + REAL, DIMENSION(klon) :: phiT0_b, dphiT0, phiQ0_b, dphiQ0, Rn0_b, dRn0 + REAL, DIMENSION(klon) :: y_delta_qsurf + REAL, DIMENSION(klon) :: y_delta_qsats + REAL, DIMENSION(klon) :: yg_T, yg_Q + REAL, DIMENSION(klon) :: yGamma_dTs_phiT, yGamma_dQs_phiQ + REAL, DIMENSION(klon) :: ydTs_ins, ydqs_ins +! + REAL, PARAMETER :: facteur=2./sqrt(3.14) + REAL, PARAMETER :: inertia=2000. + REAL, DIMENSION(klon) :: ydtsurf_th + REAL :: zdelta_surf_x,zdelta_surf_w,zx_qs_surf_x,zx_qs_surf_w + REAL :: zcor_surf_x,zcor_surf_w + REAL :: mod_wind_x, mod_wind_w + REAL :: rho1 + REAL, DIMENSION(klon) :: Kech_h ! Coefficient d'echange pour l'energie + REAL, DIMENSION(klon) :: Kech_h_x, Kech_h_w + REAL, DIMENSION(klon) :: Kech_m + REAL, DIMENSION(klon) :: Kech_m_x, Kech_m_w + REAL, DIMENSION(klon) :: yts_x, yts_w + REAL, DIMENSION(klon) :: yqsatsrf0_x, yqsatsrf0_w + REAL, DIMENSION(klon) :: yqsurf_x, yqsurf_w +!jyg< +!! REAL, DIMENSION(klon) :: Kech_Hp, Kech_H_xp, Kech_H_wp +!! REAL, DIMENSION(klon) :: Kech_Qp, Kech_Q_xp, Kech_Q_wp +!! REAL, DIMENSION(klon) :: Kech_Up, Kech_U_xp, Kech_U_wp +!! REAL, DIMENSION(klon) :: Kech_Vp, Kech_V_xp, Kech_V_wp +!>jyg + + REAL :: fact_cdrag + REAL :: z1lay + + REAL :: vent +! +! For debugging with IOIPSL + INTEGER, DIMENSION(nbp_lon*nbp_lat) :: ndexbg + REAL :: zjulian + REAL, DIMENSION(klon) :: tabindx + REAL, DIMENSION(nbp_lon,nbp_lat) :: zx_lon, zx_lat + REAL, DIMENSION(nbp_lon,nbp_lat) :: debugtab + + + REAL, DIMENSION(klon,nbsrf) :: pblh ! height of the planetary boundary layer + REAL, DIMENSION(klon,nbsrf) :: plcl ! condensation level + REAL, DIMENSION(klon,nbsrf) :: capCL + REAL, DIMENSION(klon,nbsrf) :: oliqCL + REAL, DIMENSION(klon,nbsrf) :: cteiCL + REAL, DIMENSION(klon,nbsrf) :: pblT + REAL, DIMENSION(klon,nbsrf) :: therm + REAL, DIMENSION(klon,nbsrf) :: trmb1 ! deep cape + REAL, DIMENSION(klon,nbsrf) :: trmb2 ! inhibition + REAL, DIMENSION(klon,nbsrf) :: trmb3 ! point Omega + REAL, DIMENSION(klon,nbsrf) :: zx_rh2m, zx_qsat2m + REAL, DIMENSION(klon,nbsrf) :: zx_t1 + REAL, DIMENSION(klon, nbsrf) :: alb ! mean albedo for whole SW interval + REAL, DIMENSION(klon,nbsrf) :: snowerosion + REAL, DIMENSION(klon) :: ylwdown ! jg : temporary (ysollwdown) + REAL, DIMENSION(klon) :: ygustiness ! jg : temporary (ysollwdown) + + REAL :: zx_qs1, zcor1, zdelta1 + + ! Martin + REAL, DIMENSION(klon, nbsrf) :: sollwd ! net longwave radiation at surface + REAL, DIMENSION(klon) :: ytoice + REAL, DIMENSION(klon) :: ysnowhgt, yqsnow, ysissnow, yrunoff + REAL, DIMENSION(klon) :: yzmea + REAL, DIMENSION(klon) :: yzsig + REAL, DIMENSION(klon) :: ycldt + REAL, DIMENSION(klon) :: yrmu0 + ! Martin + REAL, DIMENSION(klon) :: yri0 + + REAL, DIMENSION(klon):: ydelta_sst, ydelta_sal, yds_ns, ydt_ns, ydter, & + ydser, ydt_ds, ytkt, ytks, ytaur, ysss + ! compression of delta_sst, delta_sal, ds_ns, dt_ns, dter, dser, + ! dt_ds, tkt, tks, taur, sss on ocean points + REAL :: missing_val + + ! GG + REAL, DIMENSION(klon,klev) :: ytheta + REAL, DIMENSION(klon,klev) :: ypphii + REAL, DIMENSION(klon,klev) :: ypphi + REAL, DIMENSION(klon,klev) :: ydthetadz + REAL, DIMENSION(klon) :: ydthetadz300 + REAL, DIMENSION(klon) :: Ampl + ! GG + + ! AM ! + REAL, DIMENSION(klon) :: z0m_eff, z0h_eff, ratio_z0m_z0h_eff, albedo_eff + REAL, DIMENSION(klon, nbtersrf) :: z0h_tersrf +#ifdef ISO + REAL, DIMENSION(klon) :: h1 + INTEGER :: ixt +!#ifdef ISOVERIF +! integer iso_verif_positif_nostop +!#endif +#endif + +!**************************************************************************************** +! End of declarations +!**************************************************************************************** + IF (using_xios) THEN + missing_val=missing_val_xios + ELSE + missing_val=missing_val_netcdf + ENDIF + + IF (prt_level >=10) print *,' -> pbl_surface, itap ',itap +! +!!jyg iflag_split = mod(iflag_pbl_split,2) +!!jyg iflag_split = mod(iflag_pbl_split,10) +! +! Flags controlling the splitting of the turbulent boundary layer: +! iflag_split_ref = 0 ==> no splitting +! = 1 ==> splitting without coupling with surface temperature +! = 2 ==> splitting with coupling with surface temperature over land +! = 3 ==> splitting over ocean; no splitting over land +! iflag_split: actual flag controlling the splitting. +! iflag_split = iflag_split_ref outside the sub-surface loop +! = iflag_split_ref if iflag_split_ref = 0, 1, or 2 +! = 0 over land if iflga_split_ref = 3 +! = 1 over ocean if iflga_split_ref = 3 + + iflag_split_ref = mod(iflag_pbl_split,10) + iflag_split = iflag_split_ref + +#ifdef ISO +#ifdef ISOVERIF + DO i=1,klon + DO ixt=1,niso + CALL iso_verif_noNaN(xtsol(ixt,i),'pbl_surface 1209') + ENDDO + ENDDO +#endif +#ifdef ISOVERIF + DO i=1,klon + IF (iso_eau >= 0) THEN + CALL iso_verif_egalite_choix(Rland_ice(iso_eau,i),1.0, & + & 'pbl_surf_mod 1216',errmax,errmaxrel) + CALL iso_verif_egalite_choix(xtsnow_f(iso_eau,i),snow_f(i), & + & 'pbl_surf_mod 1218',errmax,errmaxrel) + IF (iso_verif_egalite_choix_nostop(xtsol(iso_eau,i),qsol(i), & + & 'pbl_surf_mod 1220',errmax,errmaxrel) == 1) THEN + WRITE(*,*) 'i=',i + STOP + ENDIF + DO nsrf=1,nbsrf + CALL iso_verif_egalite_choix(xtsnow(iso_eau,i,nsrf),snow(i,nsrf), & + & 'pbl_surf_mod 1226',errmax,errmaxrel) + ENDDO + ENDIF !IF (iso_eau >= 0) THEN + ENDDO !DO i=1,knon + DO k=1,klev + DO i=1,klon + IF (iso_eau >= 0) THEN + CALL iso_verif_egalite_choix(xt(iso_eau,i,k),q(i,k), & + & 'pbl_surf_mod 1234',errmax,errmaxrel) + ENDIF !IF (iso_eau >= 0) THEN + ENDDO !DO i=1,knon + ENDDO !DO k=1,klev +#endif +#endif + + +!**************************************************************************************** +! 1) Initialisation and validation tests +! Only done first time entering this subroutine +! +!**************************************************************************************** + + IF (first_call) THEN + + iflag_new_t2mq2m=1 + CALL getin_p('iflag_new_t2mq2m',iflag_new_t2mq2m) + WRITE(lunout,*) 'pbl_iflag_new_t2mq2m=',iflag_new_t2mq2m + + ok_bug_zg_wk_pbl=.TRUE. + CALL getin_p('ok_bug_zg_wk_pbl',ok_bug_zg_wk_pbl) + WRITE(lunout,*) 'ok_bug_zg_wk_pbl=',ok_bug_zg_wk_pbl + + print*,'PBL SURFACE AVEC GUSTINESS' + first_call=.FALSE. + + ! Initialize ok_flux_surf (for 1D model) + IF (klon_glo>1) ok_flux_surf=.FALSE. + IF (klon_glo>1) ok_forc_tsurf=.FALSE. + + ! intialize beta_land + beta_land = 0.5 + call getin_p('beta_land', beta_land) + + ! Initilize debug IO + IF (debugindex .AND. mpi_size==1) THEN + ! initialize IOIPSL output + idayref = day_ini + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + CALL grid1dTo2d_glo(rlon,zx_lon) + DO i = 1, nbp_lon + zx_lon(i,1) = rlon(i+1) + zx_lon(i,nbp_lat) = rlon(i+1) + ENDDO + CALL grid1dTo2d_glo(rlat,zx_lat) + CALL histbeg("sous_index",nbp_lon,zx_lon(:,1),nbp_lat,zx_lat(1,:), & + 1,nbp_lon,1,nbp_lat, & + itau_phy,zjulian,dtime,nhoridbg,nidbg) + ! no vertical axis + cl_surf(1)='ter' + cl_surf(2)='lic' + cl_surf(3)='oce' + cl_surf(4)='sic' + DO nsrf=1,nbsrf + CALL histdef(nidbg, cl_surf(nsrf),cl_surf(nsrf), "-",nbp_lon, & + nbp_lat,nhoridbg, 1, 1, 1, -99, 32, "inst", dtime,dtime) + ENDDO + + CALL histend(nidbg) + CALL histsync(nidbg) + + ENDIF + + ENDIF + +!**************************************************************************************** +! Force soil water content to qsol0 if qsol0>0 and VEGET=F (use bucket +! instead of ORCHIDEE) + IF (qsol0>=0.) THEN + PRINT*,'WARNING : On impose qsol=',qsol0 + qsol(:)=qsol0 +#ifdef ISO + DO ixt=1,niso + xtsol(ixt,:)=qsol0*Rdefault(ixt) + ENDDO +#ifdef ISOTRAC + DO ixt=1+niso,ntraciso + xtsol(ixt,:)=qsol0*Rdefault(index_iso(ixt)) + ENDDO +#endif +#endif + ENDIF +!**************************************************************************************** + +!**************************************************************************************** +! 2) Initialization to zero +!**************************************************************************************** +! +! 2a) Initialization of all argument variables with INTENT(OUT) +!**************************************************************************************** + cdragh(:)=0. ; cdragm(:)=0. + zu1(:)=0. ; zv1(:)=0. + yus0(:)=0. ; yvs0(:)=0. +!albedo SB >>> + alb_dir_m=0. ; alb_dif_m=0. ; alb3_lic(:)=0. +!albedo SB <<< + zxsens(:)=0. ; zxevap(:)=0. ; zxtsol(:)=0. ; zxsnowerosion(:)=0. + d_t_w(:,:)=0. ; d_q_w(:,:)=0. ; d_t_x(:,:)=0. ; d_q_x(:,:)=0. + zxfluxlat(:)=0. + zt2m(:)=0. ; zq2m(:)=0. ; qsat2m(:)=0. ; rh2m(:)=0. + zn2mout(:,:)=0 ; + d_t(:,:)=0. ; d_t_diss(:,:)=0. ; d_q(:,:)=0. ; d_qbs(:,:)=0. ; d_u(:,:)=0. ; d_v(:,:)=0. + zcoefh(:,:,:)=0. ; zcoefm(:,:,:)=0. + zxsens_x(:)=0. ; zxsens_w(:)=0. ; zxfluxlat_x(:)=0. ; zxfluxlat_w(:)=0. + cdragh_x(:)=0. ; cdragh_w(:)=0. ; cdragm_x(:)=0. ; cdragm_w(:)=0. + kh(:)=0. ; kh_x(:)=0. ; kh_w(:)=0. + slab_wfbils(:)=0. + s_pblh(:)=0. ; s_pblh_x(:)=0. ; s_pblh_w(:)=0. + s_plcl(:)=0. ; s_plcl_x(:)=0. ; s_plcl_w(:)=0. + s_capCL(:)=0. ; s_oliqCL(:)=0. ; s_cteiCL(:)=0. ; s_pblT(:)=0. + s_therm(:)=0. + s_trmb1(:)=0. ; s_trmb2(:)=0. ; s_trmb3(:)=0. + zustar(:)=0. + zu10m(:)=0. ; zv10m(:)=0. + fder_print(:)=0. + zxqsurf(:)=0. + delta_qsurf(:) = 0. + zxfluxu(:,:)=0. ; zxfluxv(:,:)=0. + solsw(:,:)=0. ; sollw(:,:)=0. + d_ts(:,:)=0. + evap(:,:)=0. + snowerosion(:,:)=0. + fluxlat(:,:)=0. + wfbils(:,:)=0. ; wfevap(:,:)=0. ; + flux_t(:,:,:)=0. ; flux_q(:,:,:)=0. ; flux_u(:,:,:)=0. ; flux_v(:,:,:)=0. + flux_qbs(:,:,:)=0. + dflux_t(:)=0. ; dflux_q(:)=0. + zxsnow(:)=0. + zxfluxt(:,:)=0. ; zxfluxq(:,:)=0.; zxfluxqbs(:,:)=0. + qsnow(:)=0. ; snowhgt(:)=0. ; to_ice(:)=0. ; sissnow(:)=0. + runoff(:)=0. ; icesub_lic(:)=0. +#ifdef ISO +zxxtevap(:,:)=0. + d_xt(:,:,:)=0. + d_xt_x(:,:,:)=0. + d_xt_w(:,:,:)=0. + flux_xt(:,:,:,:)=0. +! xtsnow(:,:,:)=0.! attention, xtsnow est l'équivalent de snow et non de qsnow + xtevap(:,:,:)=0. +#endif + IF (iflag_pbl<20.or.iflag_pbl>=30) THEN + zcoefh(:,:,:) = 0.0 + zcoefh(:,1,:) = 999999. ! zcoefh(:,k=1) should never be used + zcoefm(:,:,:) = 0.0 + zcoefm(:,1,:) = 999999. ! + ELSE + zcoefm(:,:,is_ave)=0. + zcoefh(:,:,is_ave)=0. + ENDIF +!! +! The components "is_ave" of tke_x and wake_deltke are "OUT" variables +!jyg< +!! tke(:,:,is_ave)=0. + tke_x(:,:,is_ave)=0. + eps_x(:,:,is_ave)=0. + + wake_dltke(:,:,is_ave)=0. +!>jyg +!!! jyg le 23/02/2013 + t2m(:,:) = 999999. ! t2m and q2m are meaningfull only over sub-surfaces + q2m(:,:) = 999999. ! actually present in the grid cell. +!!! + rh2m(:) = 0. ; qsat2m(:) = 0. +!!! +!!! jyg le 10/02/2012 + rh2m_x(:) = 0. ; qsat2m_x(:) = 0. ; rh2m_w(:) = 0. ; qsat2m_w(:) = 0. + +! 2b) Initialization of all local variables that will be compressed later +!**************************************************************************************** +!! cdragh = 0.0 ; cdragm = 0.0 ; dflux_t = 0.0 ; dflux_q = 0.0 + ypct = 0.0 ; yts = 0.0 ; ysnow = 0.0 +!! zv1 = 0.0 ; yqsurf = 0.0 +!albedo SB >>> + yqsurf = 0.0 ; yalb = 0.0 ; yalb_vis = 0.0 +!albedo SB <<< + yrain_f = 0.0 ; ysnow_f = 0.0 ; ybs_f=0.0 ; yfder = 0.0 ; ysolsw = 0.0 + ysollw = 0.0 ; yz0m = 0.0 ; yz0h = 0.0 ; yz0h_oupas = 0.0 ; yu1 = 0.0 + yv1 = 0.0 ; ypaprs = 0.0 ; ypplay = 0.0 ; yqbs1 = 0.0 + ydelp = 0.0 ; yu = 0.0 ; yv = 0.0 ; yt = 0.0 + yq = 0.0 ; y_dflux_t = 0.0 ; y_dflux_q = 0.0 + yqbs(:,:)=0.0 + yrugoro = 0.0 ; ywindsp = 0.0 +!! d_ts = 0.0 ; yfluxlat=0.0 ; flux_t = 0.0 ; flux_q = 0.0 + yfluxlat=0.0 ; y_flux0(:)=0.0 +!! flux_u = 0.0 ; flux_v = 0.0 ; d_t = 0.0 ; d_q = 0.0 +!! d_t_diss= 0.0 ;d_u = 0.0 ; d_v = 0.0 + yqsol = 0.0 + + ytke=0. + yeps=0. + yri0(:)=0. +!FC + y_treedrg=0. + + ! Martin + ysnowhgt = 0.0; yqsnow = 0.0 ; yrunoff = 0.0 ; ytoice =0.0 + yalb3_new = 0.0 ; ysissnow = 0.0 + ycldt = 0.0 ; yrmu0 = 0.0 + ! Martin + y_d_qbs(:,:)=0.0 + +!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012 + ytke_x=0. ; ytke_w=0. ; ywake_dltke=0. + yeps_x=0. ; yeps_w=0. + y_d_t_x=0. ; y_d_t_w=0. ; y_d_q_x=0. ; y_d_q_w=0. +!! d_t_w=0. ; d_q_w=0. +!! d_t_x=0. ; d_q_x=0. +!! d_wake_dlt=0. ; d_wake_dlq=0. + yfluxlat_x=0. ; yfluxlat_w=0. + ywake_s=0. ; ywake_cstar=0. ;ywake_dens=0. +!!! +!!! nrlmd le 13/06/2011 + tau_eq=0. ; delta_coef=0. + y_delta_flux_t1=0. + ydtsurf_th=0. + yts_x(:)=0. ; yts_w(:)=0. + y_delta_tsurf(:)=0. ; y_delta_qsurf(:)=0. + yqsurf_x(:)=0. ; yqsurf_w(:)=0. + yg_T(:) = 0. ; yg_Q(:) = 0. + yGamma_dTs_phiT(:) = 0. ; yGamma_dQs_phiQ(:) = 0. + ydTs_ins(:) = 0. ; ydqs_ins(:) = 0. + +!!! + ytsoil = 999999. +!FC + y_d_u_frein(:,:)=0. + y_d_v_frein(:,:)=0. +!FC + +#ifdef ISO + yxtrain_f = 0.0 ; yxtsnow_f = 0.0 + yxtsnow = 0.0 + yxt = 0.0 + yxtsol = 0.0 + flux_xt = 0.0 + yRland_ice = 0.0 + yrunoff_diag = 0.0 + yxtrunoff_diag = 0.0 + yxtriverflow = 0.0 + yxtcoastalflow = 0.0 + yRsol = 0.0 +! d_xt = 0.0 + y_dflux_xt = 0.0 + dflux_xt=0.0 + y_d_xt_x=0. ; y_d_xt_w=0. +#endif + +! >> PC +!the yfields_out variable is defined in (klon,nbcf_out) even if it is used on +!the ORCHIDEE grid and as such should be defined in yfields_out(knon,nbcf_out) but +!the knon variable is not known at that level of pbl_surface_mod + +!the yfields_in variable is defined in (klon,nbcf_in) even if it is used on the +!ORCHIDEE grid and as such should be defined in yfields_in(knon,nbcf_in) but the +!knon variable is not known at that level of pbl_surface_mod + + yfields_out(:,:) = 0. +! << PC + +!GG + ypphi = 0.0 +!GG + + +! 2c) Initialization of all local variables computed within the subsurface loop and used later on +!**************************************************************************************** + d_t_diss_x(:,:) = 0. ; d_t_diss_w(:,:) = 0. + d_u_x(:,:)=0. ; d_u_w(:,:)=0. + d_v_x(:,:)=0. ; d_v_w(:,:)=0. + flux_t_x(:,:,:)=0. ; flux_t_w(:,:,:)=0. + flux_q_x(:,:,:)=0. ; flux_q_w(:,:,:)=0. +! +!jyg< + flux_u_x(:,:,:)=0. ; flux_u_w(:,:,:)=0. + flux_v_x(:,:,:)=0. ; flux_v_w(:,:,:)=0. + fluxlat_x(:,:)=0. ; fluxlat_w(:,:)=0. +!>jyg +#ifdef ISO + flux_xt_x(:,:,:,:)=0. ; flux_xt_w(:,:,:,:)=0. +#endif +! +!jyg< +! pblh,plcl,capCL,cteiCL ... are meaningfull only over sub-surfaces +! actually present in the grid cell ==> value set to 999999. +! +!jyg< + ustar(:,:) = 999999. + wstar(:,:) = 999999. + windsp(:,:) = SQRT(u10m(:,:)**2 + v10m(:,:)**2 ) + u10m(:,:) = 999999. + v10m(:,:) = 999999. +!>jyg +! + pblh(:,:) = 999999. ! Hauteur de couche limite + plcl(:,:) = 999999. ! Niveau de condensation de la CLA + capCL(:,:) = 999999. ! CAPE de couche limite + oliqCL(:,:) = 999999. ! eau_liqu integree de couche limite + cteiCL(:,:) = 999999. ! cloud top instab. crit. couche limite + pblt(:,:) = 999999. ! T a la Hauteur de couche limite + therm(:,:) = 999999. + trmb1(:,:) = 999999. ! deep_cape + trmb2(:,:) = 999999. ! inhibition + trmb3(:,:) = 999999. ! Point Omega +! + t2m_x(:,:) = 999999. + q2m_x(:,:) = 999999. + ustar_x(:,:) = 999999. + wstar_x(:,:) = 999999. + u10m_x(:,:) = 999999. + v10m_x(:,:) = 999999. +! + pblh_x(:,:) = 999999. ! Hauteur de couche limite + plcl_x(:,:) = 999999. ! Niveau de condensation de la CLA + capCL_x(:,:) = 999999. ! CAPE de couche limite + oliqCL_x(:,:) = 999999. ! eau_liqu integree de couche limite + cteiCL_x(:,:) = 999999. ! cloud top instab. crit. couche limite + pblt_x(:,:) = 999999. ! T a la Hauteur de couche limite + therm_x(:,:) = 999999. + trmb1_x(:,:) = 999999. ! deep_cape + trmb2_x(:,:) = 999999. ! inhibition + trmb3_x(:,:) = 999999. ! Point Omega +! + t2m_w(:,:) = 999999. + q2m_w(:,:) = 999999. + ustar_w(:,:) = 999999. + wstar_w(:,:) = 999999. + u10m_w(:,:) = 999999. + v10m_w(:,:) = 999999. + + pblh_w(:,:) = 999999. ! Hauteur de couche limite + plcl_w(:,:) = 999999. ! Niveau de condensation de la CLA + capCL_w(:,:) = 999999. ! CAPE de couche limite + oliqCL_w(:,:) = 999999. ! eau_liqu integree de couche limite + cteiCL_w(:,:) = 999999. ! cloud top instab. crit. couche limite + pblt_w(:,:) = 999999. ! T a la Hauteur de couche limite + therm_w(:,:) = 999999. + trmb1_w(:,:) = 999999. ! deep_cape + trmb2_w(:,:) = 999999. ! inhibition + trmb3_w(:,:) = 999999. ! Point Omega +!!! +! +!!! +!**************************************************************************************** +! 3) - Calculate pressure thickness of each layer +! - Calculate the wind at first layer +! - Mean calculations of albedo +! - Calculate net radiance at sub-surface +!**************************************************************************************** + DO k = 1, klev + DO i = 1, klon + delp(i,k) = paprs(i,k)-paprs(i,k+1) + ENDDO + ENDDO + +!**************************************************************************************** +! Test for rugos........ from physiq.. A la fin plutot??? +! +!**************************************************************************************** + + DO nsrf = 1, nbsrf + DO i = 1, klon + z0m(i,nsrf) = MAX(z0m(i,nsrf),z0min) + z0h(i,nsrf) = MAX(z0h(i,nsrf),z0min) + ENDDO + ENDDO + + ! AM heterogeneous continental subsurfaces + ! compute time-independent effective surface parameters + IF (iflag_hetero_surf .GT. 0) THEN + albedo_eff = eff_surf_param(klon, nbtersrf, albedo_tersrf, frac_tersrf, 'ARI') + ENDIF + +! Mean calculations of albedo +! +! * alb : mean albedo for whole SW interval +! +! Mean albedo for grid point +! * alb_m : mean albedo at whole SW interval + + alb_dir_m(:,:) = 0.0 + alb_dif_m(:,:) = 0.0 + DO k = 1, nsw + DO nsrf = 1, nbsrf + DO i = 1, klon + ! AM heterogeneous continental sub-surfaces + IF (nsrf .EQ. is_ter .AND. iflag_hetero_surf .GT. 0) THEN + alb_dir(i,k,nsrf) = albedo_eff(i) + alb_dif(i,k,nsrf) = albedo_eff(i) + ENDIF + ! + alb_dir_m(i,k) = alb_dir_m(i,k) + alb_dir(i,k,nsrf) * pctsrf(i,nsrf) + alb_dif_m(i,k) = alb_dif_m(i,k) + alb_dif(i,k,nsrf) * pctsrf(i,nsrf) + ENDDO + ENDDO + ENDDO + +! We here suppose the fraction f1 of incoming radiance of visible radiance +! as a fraction of all shortwave radiance + f1 = 0.5 +! f1 = 1 ! put f1=1 to recreate old calculations + +!f1 is already included with SFRWL values in each surf files + alb=0.0 + DO k=1,nsw + DO nsrf = 1, nbsrf + DO i = 1, klon + alb(i,nsrf) = alb(i,nsrf) + alb_dir(i,k,nsrf)*SFRWL(k) + ENDDO + ENDDO + ENDDO + + alb_m=0.0 + DO k = 1,nsw + DO i = 1, klon + alb_m(i) = alb_m(i) + alb_dir_m(i,k)*SFRWL(k) + ENDDO + ENDDO +!albedo SB <<< + + + +! Calculation of mean temperature at surface grid points + ztsol(:) = 0.0 + DO nsrf = 1, nbsrf + DO i = 1, klon + ztsol(i) = ztsol(i) + ts(i,nsrf)*pctsrf(i,nsrf) + ENDDO + ENDDO + +! Linear distrubution on sub-surface of long- and shortwave net radiance + DO nsrf = 1, nbsrf + DO i = 1, klon + sollw(i,nsrf) = sollw_m(i) + 4.0*RSIGMA*ztsol(i)**3 * (ztsol(i)-ts(i,nsrf)) +!--OB this line is not satisfactory because alb is the direct albedo not total albedo + solsw(i,nsrf) = solsw_m(i) * (1.-alb(i,nsrf)) / (1.-alb_m(i)) + ENDDO + ENDDO +! +!al1 + +!--OB add diffuse fraction of SW down + DO n=1,nbcf_out + IF (cfname_out(n) == "swdownfdiff" ) fields_out(:,n) = solswfdiff_m(:) + ENDDO +! >> PC + IF (carbon_cycle_cpl .AND. carbon_cycle_tr .AND. nbcf_out.GT.0 ) THEN + r_co2_ppm(:) = co2_send(:) + DO n=1,nbcf_out + IF (cfname_out(n) == "atmco2" ) fields_out(:,n) = co2_send(:) + ENDDO + ENDIF + IF ( .NOT. carbon_cycle_tr .AND. nbcf_out.GT.0 ) THEN + r_co2_ppm(:) = co2_ppm ! Constant field + DO n=1,nbcf_out + IF (cfname_out(n) == "atmco2" ) fields_out(:,n) = co2_ppm + ENDDO + ENDIF +! << PC + +!**************************************************************************************** +! 4) Loop over different surfaces +! +! Only points containing a fraction of the sub surface will be treated. +! +!**************************************************************************************** + !<<<<<<<<<<<<< + loop_nbsrf: DO nsrf = 1, nbsrf !<<<<<<<<<<<<< + !<<<<<<<<<<<<< + IF (prt_level >=10) print *,' Loop nsrf ',nsrf +! + IF (iflag_split_ref == 3) THEN + IF (nsrf == is_oce) THEN + iflag_split = 1 + ELSE + iflag_split=0 + ENDIF !! (nsrf == is_oce) + ELSE + iflag_split = iflag_split_ref + ENDIF !! (iflag_split_ref == 3) + +! Search for index(ni) and size(knon) of domaine to treat + ni(:) = 0 + knon = 0 + DO i = 1, klon + IF (pctsrf(i,nsrf) > 0.) THEN + knon = knon + 1 + ni(knon) = i + ENDIF + ENDDO + +!!! jyg le 19/08/2012 +! IF (knon <= 0) THEN +! IF (prt_level >= 10) print *,' no grid point for nsrf= ',nsrf +! cycle loop_nbsrf +! ENDIF +!!! + + ! write index, with IOIPSL + IF (debugindex .AND. mpi_size==1) THEN + tabindx(:)=0. + DO i=1,knon + tabindx(i)=REAL(i) + ENDDO + debugtab(:,:) = 0. + ndexbg(:) = 0 + CALL gath2cpl(tabindx,debugtab,knon,ni) + CALL histwrite(nidbg,cl_surf(nsrf),itap,debugtab,nbp_lon*nbp_lat, ndexbg) + ENDIF + +!**************************************************************************************** +! 5) Compress variables +! +!**************************************************************************************** + +! +!jyg< (20190926) +! Provisional : set ybeta to standard values + IF (nsrf .NE. is_ter) THEN + ybeta(1:knon) = 1. + ELSE + IF (iflag_split .EQ. 0) THEN + ybeta(1:knon) = 1. + ELSE + DO j = 1, knon + i = ni(j) + ybeta(j) = beta(i,nsrf) + ENDDO + ENDIF ! (iflag_split .LE.1) + ENDIF ! (nsrf .NE. is_ter) +!>jyg +! + DO j = 1, knon + i = ni(j) + ypct(j) = pctsrf(i,nsrf) + yts(j) = ts(i,nsrf) + ysnow(j) = snow(i,nsrf) + yqsurf(j) = qsurf(i,nsrf) + yalb(j) = alb(i,nsrf) +!albedo SB >>> + yalb_vis(j) = alb_dir(i,1,nsrf) + IF (nsw==6) THEN + yalb_vis(j)=(alb_dir(i,1,nsrf)*SFRWL(1)+alb_dir(i,2,nsrf)*SFRWL(2) & + +alb_dir(i,3,nsrf)*SFRWL(3))/(SFRWL(1)+SFRWL(2)+SFRWL(3)) + ENDIF +!albedo SB <<< + yrain_f(j) = rain_f(i) + ysnow_f(j) = snow_f(i) + ybs_f(j) = bs_f(i) + yagesno(j) = agesno(i,nsrf) + yfder(j) = fder(i) + ylwdown(j) = lwdown_m(i) + ygustiness(j) = gustiness(i) + ysolsw(j) = solsw(i,nsrf) + ysollw(j) = sollw(i,nsrf) + yz0m(j) = z0m(i,nsrf) + yz0h(j) = z0h(i,nsrf) + yrugoro(j) = rugoro(i) + yu1(j) = u(i,1) + yv1(j) = v(i,1) + yqbs1(j) = qbs(i,1) + ypaprs(j,klev+1) = paprs(i,klev+1) +!jyg< +!! ywindsp(j) = SQRT(u10m(i,nsrf)**2 + v10m(i,nsrf)**2 ) + ywindsp(j) = windsp(i,nsrf) +!>jyg + ! Martin and Etienne + yzmea(j) = zmea(i) + yzsig(j) = zsig(i) + ycldt(j) = cldt(i) + yrmu0(j) = rmu0(i) + ! Martin +!!! nrlmd le 13/06/2011 + y_delta_tsurf(j)=delta_tsurf(i,nsrf) + yfluxbs(j)=0.0 + y_flux_bs(j) = 0.0 +!!! +#ifdef ISO + DO ixt=1,ntraciso + yxtrain_f(ixt,j) = xtrain_f(ixt,i) + yxtsnow_f(ixt,j) = xtsnow_f(ixt,i) + ENDDO + DO ixt=1,niso + yxtsnow(ixt,j) = xtsnow(ixt,i,nsrf) + ENDDO + !IF (nsrf == is_lic) THEN + DO ixt=1,niso + yRland_ice(ixt,j) = Rland_ice(ixt,i) + yxtriverflow(ixt,j) = xtriverflow(ixt,i) + yxtcoastalflow(ixt,j)= xtcoastalflow(ixt,i) + yRsol(ixt,j) = Rsol(ixt,i) + ENDDO + !endif !IF (nsrf == is_lic) THEN +#ifdef ISOVERIF + IF (iso_eau >= 0) THEN + call iso_verif_egalite_choix(ysnow_f(j), & + & yxtsnow_f(iso_eau,j),'pbl_surf_mod 862', & + & errmax,errmaxrel) + call iso_verif_egalite_choix(ysnow(j), & + & yxtsnow(iso_eau,j),'pbl_surf_mod 872', & + & errmax,errmaxrel) + ENDIF +#endif +#ifdef ISOVERIF + DO ixt=1,ntraciso + call iso_verif_noNaN(yxtsnow_f(ixt,j),'pbl_surf_mod 921') + ENDDO +#endif +#endif + ENDDO +! >> PC +!--compressing fields_out onto ORCHIDEE grid +!--these fields are shared and used directly surf_land_orchidee_mod + DO n = 1, nbcf_out + DO j = 1, knon + i = ni(j) + yfields_out(j,n) = fields_out(i,n) + ENDDO + ENDDO +! << PC + DO k = 1, klev + DO j = 1, knon + i = ni(j) + ypaprs(j,k) = paprs(i,k) + ypplay(j,k) = pplay(i,k) + ydelp(j,k) = delp(i,k) + ENDDO + ENDDO +! +!!! jyg le 07/02/2012 et le 10/04/2013 + DO k = 1, klev+1 + DO j = 1, knon + i = ni(j) +!jyg< +!! ytke(j,k) = tke(i,k,nsrf) + ytke(j,k) = tke_x(i,k,nsrf) + ENDDO + ENDDO +!>jyg + DO k = 1, klev + DO j = 1, knon + i = ni(j) + y_treedrg(j,k) = treedrg(i,k,nsrf) + yu(j,k) = u(i,k) + yv(j,k) = v(i,k) + yt(j,k) = t(i,k) + yq(j,k) = q(i,k) + yqbs(j,k)=qbs(i,k) +!! GG + ypphi(j,k) = pphi(i,k) +!! + +#ifdef ISO + DO ixt=1,ntraciso + yxt(ixt,j,k) = xt(ixt,i,k) + ENDDO !DO ixt=1,ntraciso +#endif + ENDDO + ENDDO +! + IF (iflag_split.GE.1) THEN +!!! nrlmd le 02/05/2011 + DO k = 1, klev + DO j = 1, knon + i = ni(j) + yu_x(j,k) = u(i,k) + yv_x(j,k) = v(i,k) + yt_x(j,k) = t(i,k)-wake_s(i)*wake_dlt(i,k) + yq_x(j,k) = q(i,k)-wake_s(i)*wake_dlq(i,k) + yu_w(j,k) = u(i,k) + yv_w(j,k) = v(i,k) + yt_w(j,k) = t(i,k)+(1.-wake_s(i))*wake_dlt(i,k) + yq_w(j,k) = q(i,k)+(1.-wake_s(i))*wake_dlq(i,k) +!!! +#ifdef ISO + DO ixt=1,ntraciso + yxt_x(ixt,j,k) = xt(ixt,i,k)-wake_s(i)*wake_dlxt(ixt,i,k) + yxt_w(ixt,j,k) = xt(ixt,i,k)+(1.-wake_s(i))*wake_dlxt(ixt,i,k) + ENDDO +#endif + ENDDO + ENDDO + + IF (prt_level .ge. 10) THEN + print *,'pbl_surface, wake_s(1), wake_dlt(1,:) ', wake_s(1), wake_dlt(1,:) + print *,'pbl_surface, wake_s(1), wake_dlq(1,:) ', wake_s(1), wake_dlq(1,:) + ENDIF + +!!! nrlmd le 02/05/2011 + DO k = 1, klev+1 + DO j = 1, knon + i = ni(j) +!jyg< +!! ytke_x(j,k) = tke(i,k,nsrf)-wake_s(i)*wake_dltke(i,k,nsrf) +!! ytke_w(j,k) = tke(i,k,nsrf)+(1.-wake_s(i))*wake_dltke(i,k,nsrf) +!! ywake_dltke(j,k) = wake_dltke(i,k,nsrf) +!! ytke(j,k) = tke(i,k,nsrf) +! + ytke_x(j,k) = tke_x(i,k,nsrf) + ytke(j,k) = tke_x(i,k,nsrf)+wake_s(i)*wake_dltke(i,k,nsrf) + ytke_w(j,k) = tke_x(i,k,nsrf)+wake_dltke(i,k,nsrf) + ywake_dltke(j,k) = wake_dltke(i,k,nsrf) + +!>jyg + ENDDO + ENDDO +!!! +!!! jyg le 07/02/2012 + DO j = 1, knon + i = ni(j) + ywake_s(j)=wake_s(i) + ywake_cstar(j)=wake_cstar(i) + ywake_dens(j)=wake_dens(i) + ENDDO +!!! +!!! nrlmd le 13/06/2011 + DO j=1,knon + yts_x(j)=yts(j)-ywake_s(j)*y_delta_tsurf(j) + yts_w(j)=yts(j)+(1.-ywake_s(j))*y_delta_tsurf(j) + ENDDO +!!! + ENDIF ! (iflag_split .ge.1) +!!! + DO k = 1, nsoilmx + DO j = 1, knon + i = ni(j) + ytsoil(j,k) = ftsoil(i,k,nsrf) + ENDDO + ENDDO + + ! qsol(water height in soil) only for bucket continental model + IF ( nsrf .EQ. is_ter .AND. .NOT. ok_veget ) THEN + DO j = 1, knon + i = ni(j) + yqsol(j) = qsol(i) +#ifdef ISO + DO ixt=1,niso + yxtsol(ixt,j) = xtsol(ixt,i) + ENDDO +#endif + ENDDO + ENDIF + + if (nsrf == is_oce .and. activate_ocean_skin >= 1) then + if (activate_ocean_skin == 2 .and. type_ocean == "couple") then + ydelta_sal(:knon) = delta_sal(ni(:knon)) + ydelta_sst(:knon) = delta_sst(ni(:knon)) + ydter(:knon) = dter(ni(:knon)) + ydser(:knon) = dser(ni(:knon)) + ydt_ds(:knon) = dt_ds(ni(:knon)) + end if + + yds_ns(:knon) = ds_ns(ni(:knon)) + ydt_ns(:knon) = dt_ns(ni(:knon)) + end if + +!**************************************************************************************** +! 6a) Calculate coefficients for turbulent diffusion at surface, cdragh et cdragm. +! +!**************************************************************************************** + + +!!! jyg le 07/02/2012 + IF (iflag_split .eq.0) THEN +!!! +!!! nrlmd & jyg les 02/05/2011, 13/06/2011, 05/02/2012 +! Faire disparaitre les lignes commentees fin 2015 (le temps des tests) +! CALL clcdrag( knon, nsrf, ypaprs, ypplay, & +! yu(:,1), yv(:,1), yt(:,1), yq(:,1), & +! yts, yqsurf, yrugos, & +! ycdragm, ycdragh ) +! Fuxing WANG, 04/03/2015, replace the clcdrag by the merged version: cdrag + DO i = 1, knon +! print*,'PBL ',i,RD +! print*,'PBL ',yt(i,1),ypaprs(i,1),ypplay(i,1) + zgeo1(i) = RD * yt(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) & + * (ypaprs(i,1)-ypplay(i,1)) + speed(i) = SQRT(yu(i,1)**2+yv(i,1)**2) + ENDDO +! + !!! AM heterogeneous continental subsurfaces + IF (nsrf .EQ. is_ter) THEN + ! compute time-dependent effective surface parameters (function of zgeo1) !! AM + IF (iflag_hetero_surf .GT. 0) THEN + DO i=1,klon + DO j=1,nbtersrf + IF (ratio_z0m_z0h_tersrf(i,j) .NE. 0.) THEN + z0h_tersrf(i,j) = z0m_tersrf(i,j) / ratio_z0m_z0h_tersrf(i,j) + ELSE + z0h_tersrf(i,j) = 0. + ENDIF + ENDDO + ENDDO + ! + z0m_eff = eff_surf_param(klon, nbtersrf, z0m_tersrf, frac_tersrf, 'CDN', zgeo1/RG) + z0h_eff = eff_surf_param(klon, nbtersrf, z0h_tersrf, frac_tersrf, 'CDN', zgeo1/RG) + yz0m = z0m_eff + yz0h = z0h_eff + ! + ENDIF + ENDIF +! + CALL cdrag(knon, nsrf, & + speed, yt(:,1), yq(:,1), zgeo1, ypaprs(:,1), s_pblh, & + yts, yqsurf, yz0m, yz0h, yri0, 0, & + ycdragm, ycdragh, zri1, pref, rain_f, zxtsol, ypplay(:,1)) + +! --- special Dice: on force cdragm ( a defaut de forcer ustar) MPL 05082013 + IF (ok_prescr_ust) THEN + DO i = 1, knon + print *,'ycdragm avant=',ycdragm(i) + vent= sqrt(yu(i,1)*yu(i,1)+yv(i,1)*yv(i,1)) +! ycdragm(i) = ust*ust/(1.+(yu(i,1)*yu(i,1)+yv(i,1)*yv(i,1))) +! ycdragm(i) = ust*ust/((1.+sqrt(yu(i,1)*yu(i,1)+yv(i,1)*yv(i,1))) & +! *sqrt(yu(i,1)*yu(i,1)+yv(i,1)*yv(i,1))) + ycdragm(i) = ust*ust/(1.+vent)/vent +! print *,'ycdragm ust yu yv apres=',ycdragm(i),ust,yu(i,1),yv(i,1) + ENDDO + ENDIF + + IF (prt_level >=10) print *,'cdrag -> ycdragh ', ycdragh(1:knon) + ELSE !(iflag_split .eq.0) + +! Faire disparaitre les lignes commentees fin 2015 (le temps des tests) +! CALL clcdrag( knon, nsrf, ypaprs, ypplay, & +! yu_x(:,1), yv_x(:,1), yt_x(:,1), yq_x(:,1), & +! yts_x, yqsurf, yrugos, & +! ycdragm_x, ycdragh_x ) +! Fuxing WANG, 04/03/2015, replace the clcdrag by the merged version: cdrag + DO i = 1, knon + zgeo1_x(i) = RD * yt_x(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) & + * (ypaprs(i,1)-ypplay(i,1)) + speed_x(i) = SQRT(yu_x(i,1)**2+yv_x(i,1)**2) + ENDDO + + + CALL cdrag(knon, nsrf, & + speed_x, yt_x(:,1), yq_x(:,1), zgeo1_x, ypaprs(:,1),s_pblh_x,& + yts_x, yqsurf_x, yz0m, yz0h, yri0, 0, & + ycdragm_x, ycdragh_x, zri1_x, pref_x, rain_f, zxtsol, ypplay(:,1) ) + +! --- special Dice. JYG+MPL 25112013 + IF (ok_prescr_ust) THEN + DO i = 1, knon +! print *,'ycdragm_x avant=',ycdragm_x(i) + vent= sqrt(yu_x(i,1)*yu_x(i,1)+yv_x(i,1)*yv_x(i,1)) + ycdragm_x(i) = ust*ust/(1.+vent)/vent +! print *,'ycdragm_x ust yu yv apres=',ycdragm_x(i),ust,yu_x(i,1),yv_x(i,1) + ENDDO + ENDIF + IF (prt_level >=10) print *,'clcdrag -> ycdragh_x ', ycdragh_x(1:knon) +! +! Faire disparaitre les lignes commentees fin 2015 (le temps des tests) +! CALL clcdrag( knon, nsrf, ypaprs, ypplay, & +! yu_w(:,1), yv_w(:,1), yt_w(:,1), yq_w(:,1), & +! yts_w, yqsurf, yz0m, & +! ycdragm_w, ycdragh_w ) +! Fuxing WANG, 04/03/2015, replace the clcdrag by the merged version: cdrag + DO i = 1, knon + zgeo1_w(i) = RD * yt_w(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) & + * (ypaprs(i,1)-ypplay(i,1)) + speed_w(i) = SQRT(yu_w(i,1)**2+yv_w(i,1)**2) + ENDDO + CALL cdrag(knon, nsrf, & + speed_w, yt_w(:,1), yq_w(:,1), zgeo1_w, ypaprs(:,1),s_pblh_w,& + yts_w, yqsurf_w, yz0m, yz0h, yri0, 0, & + ycdragm_w, ycdragh_w, zri1_w, pref_w, rain_f, zxtsol, ypplay(:,1) ) +! + IF(ok_bug_zg_wk_pbl) THEN + zgeo1(1:knon) = wake_s(1:knon)*zgeo1_w(1:knon) + (1.-wake_s(1:knon))*zgeo1_x(1:knon) + ELSE + zgeo1(1:knon) = ywake_s(1:knon)*zgeo1_w(1:knon) + (1.-ywake_s(1:knon))*zgeo1_x(1:knon) + ENDIF + +! --- special Dice. JYG+MPL 25112013 puis BOMEX + IF (ok_prescr_ust) THEN + DO i = 1, knon +! print *,'ycdragm_w avant=',ycdragm_w(i) + vent= sqrt(yu_w(i,1)*yu_w(i,1)+yv_w(i,1)*yv_w(i,1)) + ycdragm_w(i) = ust*ust/(1.+vent)/vent +! print *,'ycdragm_w ust yu yv apres=',ycdragm_w(i),ust,yu_w(i,1),yv_w(i,1) + ENDDO + ENDIF + IF (prt_level >=10) print *,'clcdrag -> ycdragh_w ', ycdragh_w(1:knon) +!!! + ENDIF ! (iflag_split .eq.0) +!!! + + +!**************************************************************************************** +! 6b) Calculate coefficients for turbulent diffusion in the atmosphere, ycoefh et ycoefm. +! +!**************************************************************************************** + +!!! jyg le 07/02/2012 + IF (iflag_split .eq.0) THEN +!!! nrlmd & jyg les 02/05/2011, 13/06/2011, 05/02/2012 + IF (prt_level >=10) THEN + print *,' args coef_diff_turb: yu ', yu(1:knon,:) + print *,' args coef_diff_turb: yv ', yv(1:knon,:) + print *,' args coef_diff_turb: yq ', yq(1:knon,:) + print *,' args coef_diff_turb: yt ', yt(1:knon,:) + print *,' args coef_diff_turb: yts ', yts(1:knon) + print *,' args coef_diff_turb: yz0m ', yz0m(1:knon) + print *,' args coef_diff_turb: yqsurf ', yqsurf(1:knon) + print *,' args coef_diff_turb: ycdragm ', ycdragm(1:knon) + print *,' args coef_diff_turb: ycdragh ', ycdragh(1:knon) + print *,' args coef_diff_turb: ytke ', ytke(1:knon,:) + ENDIF + + IF (iflag_pbl>=50) THEN + CALL call_atke(dtime,knon,klev,nsrf,ni,ycdragm(1:knon), ycdragh(1:knon),yus0(1:knon),yvs0(1:knon),yts(1:knon), & + yu(1:knon,:),yv(1:knon,:),yt(1:knon,:),yq(1:knon,:),ypplay(1:knon,:),ypaprs(1:knon,:), & + ytke(1:knon,:),yeps(1:knon,:), ycoefm(1:knon,:), ycoefh(1:knon,:)) + + ELSE + + CALL coef_diff_turb(dtime, nsrf, knon, ni, & + ypaprs, ypplay, yu, yv, yq, yt, yts, yqsurf, ycdragm, & + ycoefm, ycoefh, ytke, yeps, y_treedrg) +! ycoefm, ycoefh, ytke) +!FC y_treedrg ajoute + IF (iflag_pbl>=20.AND.iflag_pbl<30) THEN +! In this case, coef_diff_turb is called for the Cd only + DO k = 2, klev + DO j = 1, knon + i = ni(j) + ycoefh(j,k) = zcoefh(i,k,nsrf) + ycoefm(j,k) = zcoefm(i,k,nsrf) + ENDDO + ENDDO + ENDIF + + ENDIF ! iflag_pbl >= 50 + + IF (prt_level >=10) print *,'coef_diff_turb -> ycoefh ',ycoefh(1:knon,:) + + + ELSE !(iflag_split .eq.0) + + + IF (prt_level >=10) THEN + print *,' args coef_diff_turb: yu_x ', yu_x(1:knon,:) + print *,' args coef_diff_turb: yv_x ', yv_x(1:knon,:) + print *,' args coef_diff_turb: yq_x ', yq_x(1:knon,:) + print *,' args coef_diff_turb: yt_x ', yt_x(1:knon,:) + print *,' args coef_diff_turb: yts_x ', yts_x(1:knon) + print *,' args coef_diff_turb: yqsurf ', yqsurf(1:knon) + print *,' args coef_diff_turb: ycdragm_x ', ycdragm_x(1:knon) + print *,' args coef_diff_turb: ycdragh_x ', ycdragh_x(1:knon) + print *,' args coef_diff_turb: ytke_x ', ytke_x(1:knon,:) + ENDIF + + + IF (iflag_pbl>=50) THEN + + CALL call_atke(dtime,knon,klev,nsrf,ni,ycdragm_x(1:knon),ycdragh_x(1:knon),yus0(1:knon),yvs0(1:knon),yts_x(1:knon), & + yu_x(1:knon,:),yv_x(1:knon,:),yt_x(1:knon,:),yq_x(1:knon,:),ypplay(1:knon,:),ypaprs(1:knon,:), & + ytke_x(1:knon,:),yeps_x(1:knon,:),ycoefm_x(1:knon,:), ycoefh_x(1:knon,:)) + + ELSE + + CALL coef_diff_turb(dtime, nsrf, knon, ni, & + ypaprs, ypplay, yu_x, yv_x, yq_x, yt_x, yts_x, yqsurf_x, ycdragm_x, & + ycoefm_x, ycoefh_x, ytke_x,yeps_x,y_treedrg) +! ycoefm_x, ycoefh_x, ytke_x) +!FC doit on le mettre ( on ne l utilise pas si il y a du spliting) + IF (iflag_pbl>=20.AND.iflag_pbl<30) THEN +! In this case, coef_diff_turb is called for the Cd only + DO k = 2, klev + DO j = 1, knon + i = ni(j) + ycoefh_x(j,k) = zcoefh(i,k,nsrf) + ycoefm_x(j,k) = zcoefm(i,k,nsrf) + ENDDO + ENDDO + ENDIF + + ENDIF ! iflag_pbl >= 50 + + IF (prt_level >=10) print *,'coef_diff_turb -> ycoefh_x ',ycoefh_x(1:knon,:) +! + IF (prt_level >=10) THEN + print *,' args coef_diff_turb: yu_w ', yu_w(1:knon,:) + print *,' args coef_diff_turb: yv_w ', yv_w(1:knon,:) + print *,' args coef_diff_turb: yq_w ', yq_w(1:knon,:) + print *,' args coef_diff_turb: yt_w ', yt_w(1:knon,:) + print *,' args coef_diff_turb: yts_w ', yts_w(1:knon) + print *,' args coef_diff_turb: yqsurf ', yqsurf(1:knon) + print *,' args coef_diff_turb: ycdragm_w ', ycdragm_w(1:knon) + print *,' args coef_diff_turb: ycdragh_w ', ycdragh_w(1:knon) + print *,' args coef_diff_turb: ytke_w ', ytke_w(1:knon,:) + ENDIF + + IF (iflag_pbl>=50) THEN + + CALL call_atke(dtime,knon,klev,nsrf,ni,ycdragm_w(1:knon),ycdragh_w(1:knon),yus0(1:knon),yvs0(1:knon),yts_w(1:knon), & + yu_w(1:knon,:),yv_w(1:knon,:),yt_w(1:knon,:),yq_w(1:knon,:),ypplay(1:knon,:),ypaprs(1:knon,:), & + ytke_w(1:knon,:),yeps_w(1:knon,:),ycoefm_w(1:knon,:),ycoefh_w(1:knon,:)) + + ELSE + + CALL coef_diff_turb(dtime, nsrf, knon, ni, & + ypaprs, ypplay, yu_w, yv_w, yq_w, yt_w, yts_w, yqsurf_w, ycdragm_w, & + ycoefm_w, ycoefh_w, ytke_w,yeps_w,y_treedrg) +! ycoefm_w, ycoefh_w, ytke_w) + IF (iflag_pbl>=20.AND.iflag_pbl<30) THEN +! In this case, coef_diff_turb is called for the Cd only + DO k = 2, klev + DO j = 1, knon + i = ni(j) + ycoefh_w(j,k) = zcoefh(i,k,nsrf) + ycoefm_w(j,k) = zcoefm(i,k,nsrf) + ENDDO + ENDDO + ENDIF + + ENDIF ! iflag_pbl >= 50 + + + IF (prt_level >=10) print *,'coef_diff_turb -> ycoefh_w ',ycoefh_w(1:knon,:) + +!!!jyg le 10/04/2013 +!! En attendant de traiter le transport des traceurs dans les poches froides, formule +!! arbitraire pour ycoefh et ycoefm + DO k = 2,klev + DO j = 1,knon + ycoefh(j,k) = ycoefh_x(j,k) + ywake_s(j)*(ycoefh_w(j,k) - ycoefh_x(j,k)) + ycoefm(j,k) = ycoefm_x(j,k) + ywake_s(j)*(ycoefm_w(j,k) - ycoefm_x(j,k)) + ENDDO + ENDDO + + + ENDIF ! (iflag_split .eq.0) + + +!**************************************************************************************** +! +! 8) "La descente" - "The downhill" +! +! climb_hq_down and climb_wind_down calculate the coefficients +! Ccoef_X et Dcoef_X for X=[H, Q, U, V]. +! Only the coefficients at surface for H and Q are returned. +! +!**************************************************************************************** + +! - Calculate the coefficients Ccoef_H, Ccoef_Q, Dcoef_H and Dcoef_Q +!!! jyg le 07/02/2012 + IF (iflag_split .eq.0) THEN +!!! +!!! nrlmd & jyg les 02/05/2011, 13/06/2011, 05/02/2012 + CALL climb_hq_down(knon, ycoefh, ypaprs, ypplay, & + ydelp, yt, yq, dtime, & +!!! jyg le 09/05/2011 + CcoefH, CcoefQ, DcoefH, DcoefQ, & + Kcoef_hq, gama_q, gama_h, & +!!! + AcoefH, AcoefQ, BcoefH, BcoefQ & +#ifdef ISO + & ,yxt, CcoefXT, DcoefXT, gama_xt, AcoefXT, BcoefXT & +#endif + & ) + ELSE !(iflag_split .eq.0) + CALL climb_hq_down(knon, ycoefh_x, ypaprs, ypplay, & + ydelp, yt_x, yq_x, dtime, & +!!! nrlmd le 02/05/2011 + CcoefH_x, CcoefQ_x, DcoefH_x, DcoefQ_x, & + Kcoef_hq_x, gama_q_x, gama_h_x, & +!!! + AcoefH_x, AcoefQ_x, BcoefH_x, BcoefQ_x & +#ifdef ISO + & ,yxt_x, CcoefXT_x, DcoefXT_x, gama_xt_x, AcoefXT_x, BcoefXT_x & +#endif + & ) +!!! + IF (prt_level >=10) THEN + PRINT *,'pbl_surface (climb_hq_down.x->) AcoefH_x ',AcoefH_x + PRINT *,'pbl_surface (climb_hq_down.x->) AcoefQ_x ',AcoefQ_x + PRINT *,'pbl_surface (climb_hq_down.x->) BcoefH_x ',BcoefH_x + PRINT *,'pbl_surface (climb_hq_down.x->) BcoefQ_x ',BcoefQ_x + ENDIF +! + CALL climb_hq_down(knon, ycoefh_w, ypaprs, ypplay, & + ydelp, yt_w, yq_w, dtime, & +!!! nrlmd le 02/05/2011 + CcoefH_w, CcoefQ_w, DcoefH_w, DcoefQ_w, & + Kcoef_hq_w, gama_q_w, gama_h_w, & +!!! + AcoefH_w, AcoefQ_w, BcoefH_w, BcoefQ_w & +#ifdef ISO + & ,yxt_w, CcoefXT_w, DcoefXT_w, gama_xt_w, AcoefXT_w, BcoefXT_w & +#endif + & ) +!!! + IF (prt_level >=10) THEN + PRINT *,'pbl_surface (climb_hq_down.w->) AcoefH_w ',AcoefH_w + PRINT *,'pbl_surface (climb_hq_down.w->) AcoefQ_w ',AcoefQ_w + PRINT *,'pbl_surface (climb_hq_down.w->) BcoefH_w ',BcoefH_w + PRINT *,'pbl_surface (climb_hq_down.w->) BcoefQ_w ',BcoefQ_w + ENDIF +!!! + ENDIF ! (iflag_split .eq.0) +!!! + +! - Calculate the coefficients Ccoef_U, Ccoef_V, Dcoef_U and Dcoef_V +!!! jyg le 07/02/2012 + IF (iflag_split .eq.0) THEN +!!! nrlmd & jyg les 02/05/2011, 13/06/2011, 05/02/2012 + CALL climb_wind_down(knon, dtime, ycoefm, ypplay, ypaprs, yt, ydelp, yu, yv, & +!!! jyg le 09/05/2011 + CcoefU, CcoefV, DcoefU, DcoefV, & + Kcoef_m, alf_1, alf_2, & +!!! + AcoefU, AcoefV, BcoefU, BcoefV) + ELSE ! (iflag_split .eq.0) + CALL climb_wind_down(knon, dtime, ycoefm_x, ypplay, ypaprs, yt_x, ydelp, yu_x, yv_x, & +!!! nrlmd le 02/05/2011 + CcoefU_x, CcoefV_x, DcoefU_x, DcoefV_x, & + Kcoef_m_x, alf_1_x, alf_2_x, & +!!! + AcoefU_x, AcoefV_x, BcoefU_x, BcoefV_x) +! + CALL climb_wind_down(knon, dtime, ycoefm_w, ypplay, ypaprs, yt_w, ydelp, yu_w, yv_w, & +!!! nrlmd le 02/05/2011 + CcoefU_w, CcoefV_w, DcoefU_w, DcoefV_w, & + Kcoef_m_w, alf_1_w, alf_2_w, & +!!! + AcoefU_w, AcoefV_w, BcoefU_w, BcoefV_w) +!!! + ENDIF ! (iflag_split .eq.0) +!!! + +! For blowing snow: + IF (ok_bs) THEN + ! following Bintanja et al 2000, part II and Vionnet V PhD thesis + ! we assume that the eddy diffsivity coefficient for + ! suspended particles is a fraction of Kh + do k=1,klev + do j=1,knon + ycoefqbs(j,k)=ycoefh(j,k)*zeta_bs + enddo + enddo + CALL climb_qbs_down(knon, ycoefqbs, ypaprs, ypplay, & + ydelp, yt, yqbs, dtime, & + CcoefQBS, DcoefQBS, & + Kcoef_qbs, gama_qbs, & + AcoefQBS, BcoefQBS) + ENDIF + +!**************************************************************************************** +! 9) Small calculations +! +!**************************************************************************************** + +! - Reference pressure is given the values at surface level + ypsref(:) = ypaprs(:,1) + +! - CO2 field on 2D grid to be sent to ORCHIDEE +! Transform to compressed field + IF (carbon_cycle_cpl) THEN + DO i=1,knon + r_co2_ppm(i) = co2_send(ni(i)) + ENDDO + ELSE + r_co2_ppm(:) = co2_ppm ! Constant field + ENDIF + +!!! nrlmd le 02/05/2011 -----------------------On raccorde les 2 colonnes dans la couche 1 +!---------------------------------------------------------------------------------------- +!!! jyg le 07/02/2012 +!!! jyg le 01/02/2017 + IF (iflag_split .eq. 0) THEN + yt1(:) = yt(:,1) + yq1(:) = yq(:,1) +#ifdef ISO + yxt1(:,:) = yxt(:,:,1) +#endif + + ELSE IF (iflag_split .ge. 1) THEN +#ifdef ISO + call abort_physic('pbl_surface_mod 2149','isos pas encore dans iflag_split=1',1) +#endif + +! +! Cdragq computation +! ------------------ + !****************************************************************************** + ! Cdragq computed from cdrag + ! The difference comes only from a factor (f_z0qh_oce) on z0, so that + ! it can be computed inside wx_pbl0_merge + ! More complicated appraches may require the propagation through + ! pbl_surface of an independant cdragq variable. + !****************************************************************************** +! + IF ( f_z0qh_oce .ne. 1. .and. nsrf .eq.is_oce) THEN + ! Si on suit les formulations par exemple de Tessel, on + ! a z0h=0.4*nu/u*, z0q=0.62*nu/u*, d'ou f_z0qh_oce=0.62/0.4=1.55 +!! ycdragq_x(1:knon)=ycdragh_x(1:knon)* & +!! log(z1lay(1:knon)/yz0h(1:knon))/log(z1lay(1:knon)/(f_z0qh_oce*yz0h(1:knon))) +!! ycdragq_w(1:knon)=ycdragh_w(1:knon)* & +!! log(z1lay(1:knon)/yz0h(1:knon))/log(z1lay(1:knon)/(f_z0qh_oce*yz0h(1:knon))) +! + DO j = 1,knon + z1lay = zgeo1(j)/RG + fact_cdrag = log(z1lay/yz0h(j))/log(z1lay/(f_z0qh_oce*yz0h(j))) + ycdragq_x(j)=ycdragh_x(j)*fact_cdrag + ycdragq_w(j)=ycdragh_w(j)*fact_cdrag +!! Print *,'YYYYpbl0: fact_cdrag ', fact_cdrag + ENDDO ! j = 1,knon +! +!! Print *,'YYYYpbl0: z1lay, yz0h, f_z0qh_oce, ycdragh_w, ycdragq_w ', & +!! z1lay, yz0h(1:knon), f_z0qh_oce, ycdragh_w(1:knon), ycdragq_w(1:knon) + ELSE + ycdragq_x(1:knon)=ycdragh_x(1:knon) + ycdragq_w(1:knon)=ycdragh_w(1:knon) + ENDIF ! ( f_z0qh_oce .ne. 1. .and. nsrf .eq.is_oce) +! + CALL wx_pbl_prelim_0(knon, nsrf, dtime, ypplay, ypaprs, ywake_s, & + yts, y_delta_tsurf, ygustiness, & + yt_x, yt_w, yq_x, yq_w, & + yu_x, yu_w, yv_x, yv_w, & + ycdragh_x, ycdragh_w, ycdragq_x, ycdragq_w, & + ycdragm_x, ycdragm_w, & + AcoefH_x, AcoefH_w, AcoefQ_x, AcoefQ_w, & + AcoefU_x, AcoefU_w, AcoefV_x, AcoefV_w, & + BcoefH_x, BcoefH_w, BcoefQ_x, BcoefQ_w, & + BcoefU_x, BcoefU_w, BcoefV_x, BcoefV_w, & + Kech_h_x, Kech_h_w, Kech_h & + ) + CALL wx_pbl_prelim_beta(knon, dtime, ywake_s, ybeta, & + BcoefQ_x, BcoefQ_w & + ) + CALL wx_pbl0_merge(knon, ypplay, ypaprs, & + ywake_s, ydTs0, ydqs0, & + yt_x, yt_w, yq_x, yq_w, & + yu_x, yu_w, yv_x, yv_w, & + ycdragh_x, ycdragh_w, ycdragq_x, ycdragq_w, & + ycdragm_x, ycdragm_w, & + AcoefH_x, AcoefH_w, AcoefQ_x, AcoefQ_w, & + AcoefU_x, AcoefU_w, AcoefV_x, AcoefV_w, & + BcoefH_x, BcoefH_w, BcoefQ_x, BcoefQ_w, & + BcoefU_x, BcoefU_w, BcoefV_x, BcoefV_w, & + AcoefH_0, AcoefQ_0, AcoefU, AcoefV, & + BcoefH_0, BcoefQ_0, BcoefU, BcoefV, & + ycdragh, ycdragq, ycdragm, & + yt1, yq1, yu1, yv1 & + ) + IF (iflag_split .eq. 2 .AND. nsrf .ne. is_oce) THEN + CALL wx_pbl_dts_merge(knon, dtime, ypplay, ypaprs, & + ywake_s, ybeta, ywake_cstar, ywake_dens, & + AcoefH_x, AcoefH_w, & + BcoefH_x, BcoefH_w, & + AcoefH_0, AcoefQ_0, BcoefH_0, BcoefQ_0, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + HTphiT_b, dd_HTphiT, HTphiQ_b, dd_HTphiQ, HTRn_b, dd_HTRn, & + phiT0_b, dphiT0, phiQ0_b, dphiQ0, Rn0_b, dRn0, & + yg_T, yg_Q, & + yGamma_dTs_phiT, yGamma_dQs_phiQ, & + ydTs_ins, ydqs_ins & + ) + ELSE ! + AcoefH(:) = AcoefH_0(:) + AcoefQ(:) = AcoefQ_0(:) + BcoefH(:) = BcoefH_0(:) + BcoefQ(:) = BcoefQ_0(:) + yg_T(:) = 0. + yg_Q(:) = 0. + yGamma_dTs_phiT(:) = 0. + yGamma_dQs_phiQ(:) = 0. + ydTs_ins(:) = 0. + ydqs_ins(:) = 0. + ENDIF ! (iflag_split .eq. 2) + ENDIF ! (iflag_split .eq.0) +!!! + IF (prt_level >=10) THEN + DO i = 1, min(1,knon) + PRINT *,'pbl_surface (merge->): yt(1,:) ',yt(i,:) + PRINT *,'pbl_surface (merge->): yq(1,:) ',yq(i,:) + PRINT *,'pbl_surface (merge->): yu(1,:) ',yu(i,:) + PRINT *,'pbl_surface (merge->): yv(1,:) ',yv(i,:) + PRINT *,'pbl_surface (merge->): AcoefH(1), AcoefQ(1), AcoefU(1), AcoefV(1) ', & + AcoefH(i), AcoefQ(i), AcoefU(i), AcoefV(i) + PRINT *,'pbl_surface (merge->): BcoefH(1), BcoefQ(1), BcoefU(1), BcoefV(1) ', & + BcoefH(i), BcoefQ(i), BcoefU(i), BcoefV(i) + ENDDO + + ENDIF + +! Save initial value of z0h for use in evappot (z0h wiil be computed again in the surface models) + yz0h_old(1:knon) = yz0h(1:knon) +! +!**************************************************************************************** +! +! Calulate t2m and q2m for the case of calculation at land grid points +! t2m and q2m are needed as input to ORCHIDEE +! +!**************************************************************************************** + IF (nsrf == is_ter) THEN + + DO i = 1, knon + zgeo1(i) = RD * yt(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) & + * (ypaprs(i,1)-ypplay(i,1)) + ENDDO + + ! Calculate the temperature et relative humidity at 2m and the wind at 10m + IF (iflag_new_t2mq2m==1) THEN + CALL stdlevvarn(klon, knon, is_ter, zxli, & + yu(:,1), yv(:,1), yt(:,1), yq(:,1), zgeo1, & + yts, yqsurf, yz0m, yz0h, ypaprs(:,1), ypplay(:,1), & + yt2m, yq2m, yt10m, yq10m, yu10m, yustar, & + yn2mout(:, nsrf, :)) + ELSE + CALL stdlevvar(klon, knon, is_ter, zxli, & + yu(:,1), yv(:,1), yt(:,1), yq(:,1), zgeo1, & + yts, yqsurf, yz0m, yz0h, ypaprs(:,1), ypplay(:,1), & + yt2m, yq2m, yt10m, yq10m, yu10m, yustar, ypblh, rain_f, zxtsol) + ENDIF + + ENDIF + +!**************************************************************************************** +! +! 10) Switch according to current surface +! It is necessary to start with the continental surfaces because the ocean +! needs their run-off. +! +!**************************************************************************************** + SELECT CASE(nsrf) + + CASE(is_ter) +! print*,"DEBUGTS",yts(knon/2),ylwdown(knon/2) + CALL surf_land(itap, dtime, date0, jour, knon, ni,& + rlon, rlat, yrmu0, & + debut, lafin, ydelp(:,1), r_co2_ppm, ysolsw, ysollw, yalb, & +!!jyg yts, ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),& + yts, ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, ybs_f, yt1, yq1,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ypsref, yu1, yv1, ygustiness, yrugoro, pctsrf, & + ylwdown, yq2m, yt2m, & + ysnow, yqsol, yagesno, ytsoil, & + yz0m, yz0h, SFRWL, yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,yfluxbs,& + yqsurf, ytsurf_new, y_dflux_t, y_dflux_q, & + y_flux_u1, y_flux_v1, & + yveget,ylai,yheight, tsurf_tersrf, tsoil_tersrf, qsurf_tersrf, tsurf_new_tersrf, & + cdragm_tersrf, cdragh_tersrf, & + swnet_tersrf, lwnet_tersrf, fluxsens_tersrf, fluxlat_tersrf & +!GG +! yveget,ylai,yheight,hice,tice,bilg_cumul, & +! fcds, fcdi, dh_basal_growth, dh_basal_melt, dh_top_melt, dh_snow2sic, & +! dtice_melt, dtice_snow2sic) + !GG +#ifdef ISO + & ,yxtrain_f, yxtsnow_f,yxt1, & + & yxtsnow,yxtsol,yxtevap,h1, & + & yrunoff_diag,yxtrunoff_diag,yRland_ice, & + & yxtriverflow,yxtcoastalflow,yRsol & +#endif + & ) + + tsurf_tersrf(:,:) = tsurf_new_tersrf(:,:) ! for next time step + +!FC quid qd yveget ylai yheight ne sont pas definit +!FC yveget,ylai,yheight, & + IF (ifl_pbltree .ge. 1) THEN + CALL freinage(knon, yu, yv, yt, & +! yveget,ylai, yheight,ypaprs,ypplay,y_d_u_frein,y_d_v_frein) + yveget,ylai, yheight,ypaprs,ypplay,y_treedrg, y_d_u_frein,y_d_v_frein) + ENDIF + + +! Special DICE MPL 05082013 puis BOMEX + IF (ok_prescr_ust) THEN + DO j=1,knon +! ysnow(:)=0. +! yqsol(:)=0. +! yagesno(:)=50. +! ytsoil(:,:)=300. +! yz0_new(:)=0.001 +! yevap(:)=flat/RLVTT +! yfluxlat(:)=-flat +! yfluxsens(:)=-fsens +! yqsurf(:)=0. +! ytsurf_new(:)=tg +! y_dflux_t(:)=0. +! y_dflux_q(:)=0. + y_flux_u1(j)=ycdragm(j)*(1.+sqrt(yu(j,1)*yu(j,1)+yv(j,1)*yv(j,1)))*yu(j,1)*ypplay(j,1)/RD/yt(j,1) + y_flux_v1(j)=ycdragm(j)*(1.+sqrt(yu(j,1)*yu(j,1)+yv(j,1)*yv(j,1)))*yv(j,1)*ypplay(j,1)/RD/yt(j,1) + ENDDO + ENDIF + +#ifdef ISOVERIF + DO j=1,knon + DO ixt=1,ntraciso + CALL iso_verif_noNaN(yxtevap(ixt,j), & + & 'pbl_surface 1056a: apres surf_land') + ENDDO + DO ixt=1,niso + CALL iso_verif_noNaN(yxtsol(ixt,j), & + & 'pbl_surface 1056b: apres surf_land') + ENDDO + ENDDO +#endif +#ifdef ISOVERIF +! write(*,*) 'pbl_surface_mod 1038: sortie surf_land' + DO j=1,knon + IF (iso_eau >= 0) THEN + CALL iso_verif_egalite(yxtsnow(iso_eau,j), & + & ysnow(j),'pbl_surf_mod 1043') + ENDIF !if (iso_eau.gt.0) then + ENDDO !DO i=1,klon +#endif + + CASE(is_lic) + ! Martin + + IF (landice_opt .LT. 2) THEN + ! Land ice is treated by LMDZ and not by ORCHIDEE + CALL surf_landice(itap, dtime, knon, ni, & + rlon, rlat, debut, lafin, & + yrmu0, ylwdown, yalb, zgeo1, & + ysolsw, ysollw, yts, ypplay(:,1), & + ycdragh, ycdragm, yrain_f, ysnow_f, ybs_f, yt1, yq1,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + AcoefQBS, BcoefQBS, & + ypsref, yu1, yv1, ygustiness, yrugoro, pctsrf, & + ysnow, yqsurf, yqsol,yqbs1, yagesno, & + ytsoil, yz0m, yz0h, SFRWL, yalb_dir_new, yalb_dif_new, yevap, yicesub_lic, yfluxsens, yfluxlat, & + yfluxbs, ytsurf_new, y_dflux_t, y_dflux_q, & + yzmea, yzsig, ycldt, & + ysnowhgt, yqsnow, ytoice, ysissnow, & + yalb3_new, yrunoff, & + y_flux_u1, y_flux_v1 & +#ifdef ISO + & ,yxtrain_f, yxtsnow_f,yxt1,yRland_ice & + & ,yxtsnow,yxtsol,yxtevap & +#endif + & ) + + !jyg< + !! alb3_lic(:)=0. + !>jyg + DO j = 1, knon + i = ni(j) + alb3_lic(i) = yalb3_new(j) + snowhgt(i) = ysnowhgt(j) + qsnow(i) = yqsnow(j) + to_ice(i) = ytoice(j) + sissnow(i) = ysissnow(j) + runoff(i) = yrunoff(j) + icesub_lic(i) = yicesub_lic(j)*ypct(j) + ENDDO + ! Martin + ! Special DICE MPL 05082013 puis BOMEX MPL 20150410 + IF (ok_prescr_ust) THEN + DO j=1,knon + y_flux_u1(j)=ycdragm(j)*(1.+sqrt(yu(j,1)*yu(j,1)+yv(j,1)*yv(j,1)))*yu(j,1)*ypplay(j,1)/RD/yt(j,1) + y_flux_v1(j)=ycdragm(j)*(1.+sqrt(yu(j,1)*yu(j,1)+yv(j,1)*yv(j,1)))*yv(j,1)*ypplay(j,1)/RD/yt(j,1) + ENDDO + ENDIF + +#ifdef ISOVERIF + DO j=1,knon + DO ixt=1,ntraciso + CALL iso_verif_noNaN(yxtevap(ixt,j), & + & 'pbl_surface 2716a: apres surf_landice') + ENDDO + DO ixt=1,niso + CALL iso_verif_noNaN(yxtsol(ixt,j), & + & 'pbl_surface 2720b: apres surf_landice') + ENDDO + ENDDO +#endif +#ifdef ISOVERIF + !write(*,*) 'pbl_surface_mod 1060: sortie surf_landice' + DO j=1,knon + IF (iso_eau >= 0) THEN + CALL iso_verif_egalite(yxtsnow(iso_eau,j), & + & ysnow(j),'pbl_surf_mod 2729') + ENDIF !if (iso_eau >= 0) THEN + ENDDO !DO i=1,klon +#endif + + END IF + + CASE(is_oce) + +!GG +! calculate length scale PBL + + if (iflag_leads == 1) then + ydthetadz = 999999. + ypphii = 999999. + ytheta = 999999. + + DO k = 1, klev + DO j = 1, knon + ytheta(j,k) = yt(j,k)*(ypplay(j,k)/1.e5)**(RD/RCPD) + ENDDO + ENDDO + + DO k = 2, klev + DO j = 1, knon + ydthetadz(j,k) = RG*( ytheta(j,k) - ytheta(j,k-1) ) / ( ypphi(j,k) - ypphi(j,k-1) ) + ypphii(j,k) = (ypphi(j,k)+ypphi(j,k-1))/(RG*2.) + ENDDO + ENDDO + + DO j = 1, knon + ! print *, "ypphii(j,:)=", ypphii(j,:) + ! print *, "ypplay(j,:)=", ypplay(j,:) + ! print *, "ytheta(j,:)=", ytheta(j,:) + ! print *, "minloc(abs(ypphii(j,:)-300))=", + ! minloc(abs(ypphii(j,:)-300),1) + k= minloc(abs(ypphii(j,:)-300),1) + ydthetadz300(j)=ydthetadz(j,k) + ENDDO + end if +!GG + CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb_vis, & + ywindsp, rmu0, yfder, yts, & + itap, dtime, jour, knon, ni, & +!!jyg ypplay(:,1), zgeo1/RG, ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),& + ypplay(:,1), zgeo1(1:knon)/RG, ycdragh, ycdragm, yrain_f, ysnow_f, ybs_f, yt(:,1), yq(:,1),& ! ym missing init + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ypsref, yu1, yv1, ygustiness, yrugoro, pctsrf, & + ysnow, yqsurf, yagesno, & + yz0m, yz0h, SFRWL,yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,& + ytsurf_new, y_dflux_t, y_dflux_q, slab_wfbils, & + y_flux_u1, y_flux_v1, ydelta_sst(:knon), ydelta_sal(:knon), & + yds_ns(:knon), ydt_ns(:knon), ydter(:knon), ydser(:knon), & + !GG ydt_ds(:knon), ytkt(:knon), ytks(:knon), ytaur(:knon), ysss) + ydt_ds(:knon), ytkt(:knon), ytks(:knon), ytaur(:knon), ysss, & + ydthetadz300,Ampl & + !GG +#ifdef ISO + & ,yxtrain_f, yxtsnow_f,yxt1,Roce, & + & yxtsnow,yxtevap,h1 & +#endif + & ) + IF (prt_level >=10) THEN + print *,'arg de surf_ocean: ycdragh ',ycdragh(1:knon) + print *,'arg de surf_ocean: ycdragm ',ycdragm(1:knon) + print *,'arg de surf_ocean: yt ', yt(1:knon,:) + print *,'arg de surf_ocean: yq ', yq(1:knon,:) + print *,'arg de surf_ocean: yts ', yts(1:knon) + print *,'arg de surf_ocean: AcoefH ',AcoefH(1:knon) + print *,'arg de surf_ocean: AcoefQ ',AcoefQ(1:knon) + print *,'arg de surf_ocean: BcoefH ',BcoefH(1:knon) + print *,'arg de surf_ocean: BcoefQ ',BcoefQ(1:knon) + print *,'arg de surf_ocean: yevap ',yevap(1:knon) + print *,'arg de surf_ocean: yfluxsens ',yfluxsens(1:knon) + print *,'arg de surf_ocean: yfluxlat ',yfluxlat(1:knon) + print *,'arg de surf_ocean: ytsurf_new ',ytsurf_new(1:knon) + ENDIF +! Special DICE MPL 05082013 puis BOMEX MPL 20150410 + IF (ok_prescr_ust) THEN + DO j=1,knon + y_flux_u1(j)=ycdragm(j)*(1.+sqrt(yu(j,1)*yu(j,1)+yv(j,1)*yv(j,1)))*yu(j,1)*ypplay(j,1)/RD/yt(j,1) + y_flux_v1(j)=ycdragm(j)*(1.+sqrt(yu(j,1)*yu(j,1)+yv(j,1)*yv(j,1)))*yv(j,1)*ypplay(j,1)/RD/yt(j,1) + ENDDO + ENDIF + + CASE(is_sic) + CALL surf_seaice( & +!albedo SB >>> + rlon, rlat, ysolsw, ysollw, yalb_vis, yfder, & +!albedo SB <<< + itap, dtime, jour, knon, ni, & + lafin, & +!!jyg yts, ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),& + yts, ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt1, yq1,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ypsref, yu1, yv1, ygustiness, pctsrf, & + ysnow, yqsurf, yqsol, yagesno, ytsoil, & +!albedo SB >>> + yz0m, yz0h, SFRWL, yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,& +!albedo SB <<< + ytsurf_new, y_dflux_t, y_dflux_q, & +!GG y_flux_u1, y_flux_v1) + y_flux_u1, y_flux_v1, & + hice,tice,bilg_cumul, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic & +!GG +#ifdef ISO + & ,yxtrain_f, yxtsnow_f,yxt1,Roce, & + & yxtsnow,yxtsol,yxtevap,Rland_ice & +#endif + & ) + +! Special DICE MPL 05082013 puis BOMEX MPL 20150410 + IF (ok_prescr_ust) THEN + DO j=1,knon + y_flux_u1(j)=ycdragm(j)*(1.+sqrt(yu(j,1)*yu(j,1)+yv(j,1)*yv(j,1)))*yu(j,1)*ypplay(j,1)/RD/yt(j,1) + y_flux_v1(j)=ycdragm(j)*(1.+sqrt(yu(j,1)*yu(j,1)+yv(j,1)*yv(j,1)))*yv(j,1)*ypplay(j,1)/RD/yt(j,1) + ENDDO + ENDIF + +#ifdef ISOVERIF + DO j=1,knon + DO ixt=1,ntraciso + CALL iso_verif_noNaN(yxtevap(ixt,j), & + & 'pbl_surface 1165a: apres surf_seaice') + ENDDO + DO ixt=1,niso + CALL iso_verif_noNaN(yxtsol(ixt,j), & + & 'pbl_surface 1165b: apres surf_seaice') + ENDDO + ENDDO +#endif +#ifdef ISOVERIF + !write(*,*) 'pbl_surface_mod 1077: sortie surf_seaice' + DO j=1,knon + IF (iso_eau >= 0) THEN + CALL iso_verif_egalite(yxtsnow(iso_eau,j), & + & ysnow(j),'pbl_surf_mod 1106') + ENDIF !IF (iso_eau >= 0) THEN + ENDDO !DO i=1,klon +#endif + + CASE DEFAULT + WRITE(lunout,*) 'Surface index = ', nsrf + abort_message = 'Surface index not valid' + CALL abort_physic(modname,abort_message,1) + END SELECT + + +!**************************************************************************************** +! 11) - Calcul the increment of surface temperature +! +!**************************************************************************************** + + IF (evap0>=0.) THEN + yevap(1:knon)=evap0 + yevap(1:knon)=RLVTT*evap0 + ENDIF + + y_d_ts(1:knon) = ytsurf_new(1:knon) - yts(1:knon) + +!**************************************************************************************** +! +! 12) "La remontee" - "The uphill" +! +! The fluxes (y_flux_X) and tendancy (y_d_X) are calculated +! for X=H, Q, U and V, for all vertical levels. +! +!**************************************************************************************** +!! +!!! +!!! jyg le 10/04/2013 et EV 10/2020 + + IF (ok_forc_tsurf) THEN + DO j=1,knon + ytsurf_new(j)=tg + y_d_ts(j) = ytsurf_new(j) - yts(j) + ENDDO + ENDIF ! ok_forc_tsurf + +!!! + IF (ok_flux_surf) THEN + IF (prt_level >=10) THEN + PRINT *,'pbl_surface: fsens flat RLVTT=',fsens,flat,RLVTT + ENDIF + y_flux_t1(:) = fsens + y_flux_q1(:) = flat/RLVTT + yfluxlat(:) = flat +! +!! Test sur iflag_split retire le 2/02/2018, sans vraiment comprendre la raison de ce test. (jyg) +!! IF (iflag_split .eq.0) THEN + DO j=1,knon + Kech_h(j) = ycdragh(j) * (1.0+SQRT(yu(j,1)**2+yv(j,1)**2)) * & + ypplay(j,1)/(RD*yt(j,1)) + ENDDO +!! ENDIF ! (iflag_split .eq.0) + + DO j = 1, knon + yt1_new=(1./RCPD)*(AcoefH(j)+BcoefH(j)*y_flux_t1(j)*dtime) + ytsurf_new(j)=yt1_new-y_flux_t1(j)/(Kech_h(j)*RCPD) + ! for cases forced in flux and for which forcing in Ts is needed + ! to prevent the latter to reach unrealistic value (even if not used, + ! Ts is calculated and hgardfou can appear during the calculation + ! of surface saturation humidity for example + if (ok_forc_tsurf) ytsurf_new(j)=tg + ENDDO + + DO j=1,knon + y_d_ts(j) = ytsurf_new(j) - yts(j) + ENDDO + + ELSE ! (ok_flux_surf) + DO j=1,knon + y_flux_t1(j) = yfluxsens(j) + y_flux_q1(j) = -yevap(j) +#ifdef ISO + y_flux_xt1(:,:) = -yxtevap(:,:) +#endif + ENDDO + ENDIF ! (ok_flux_surf) + + ! flux of blowing snow at the first level + IF (ok_bs) THEN + DO j=1,knon + y_flux_bs(j)=yfluxbs(j) + ENDDO + ENDIF +! +! ------------------------------------------------------------------------------ +! 12a) Splitting +! ------------------------------------------------------------------------------ + + IF (iflag_split .GE. 1) THEN +#ifdef ISO + call abort_physic('pbl_surface_mod 2607','isos pas encore dans iflag_split=1',1) +#endif +! +! + IF (nsrf .ne. is_oce) THEN +! +! Compute potential evaporation and aridity factor (jyg, 20200328) + ybeta_prev(:) = ybeta(:) + DO j = 1, knon + yqa(j) = AcoefQ(j) - BcoefQ(j)*yevap(j)*dtime + ENDDO +! + CALL wx_evappot(knon, yqa, yTsurf_new, yevap_pot) +! + ybeta(1:knon) = min(yevap(1:knon)/yevap_pot(1:knon), 1.) + + IF (prt_level >=10) THEN + DO j=1,knon + print*,'y_flux_t1,yfluxlat,wakes' & + & , y_flux_t1(j), yfluxlat(j), ywake_s(j) + print*,'beta_prev, beta, ytsurf_new', ybeta_prev(j), ybeta(j), ytsurf_new(j) + print*,'inertia,facteur,cstar', inertia, facteur,wake_cstar(j) + ENDDO + ENDIF ! (prt_level >=10) +! +! Second call to wx_pbl0_merge and wx_pbl_dts_merge in order to take into account +! the update of the aridity coeficient beta. +! + CALL wx_pbl_prelim_beta(knon, dtime, ywake_s, ybeta, & + BcoefQ_x, BcoefQ_w & + ) + CALL wx_pbl0_merge(knon, ypplay, ypaprs, & + ywake_s, ydTs0, ydqs0, & + yt_x, yt_w, yq_x, yq_w, & + yu_x, yu_w, yv_x, yv_w, & + ycdragh_x, ycdragh_w, ycdragq_x, ycdragq_w, & + ycdragm_x, ycdragm_w, & + AcoefH_x, AcoefH_w, AcoefQ_x, AcoefQ_w, & + AcoefU_x, AcoefU_w, AcoefV_x, AcoefV_w, & + BcoefH_x, BcoefH_w, BcoefQ_x, BcoefQ_w, & + BcoefU_x, BcoefU_w, BcoefV_x, BcoefV_w, & + AcoefH_0, AcoefQ_0, AcoefU, AcoefV, & + BcoefH_0, BcoefQ_0, BcoefU, BcoefV, & + ycdragh, ycdragq, ycdragm, & + yt1, yq1, yu1, yv1 & + ) + IF (iflag_split .eq. 2) THEN + CALL wx_pbl_dts_merge(knon, dtime, ypplay, ypaprs, & + ywake_s, ybeta, ywake_cstar, ywake_dens, & + AcoefH_x, AcoefH_w, & + BcoefH_x, BcoefH_w, & + AcoefH_0, AcoefQ_0, BcoefH_0, BcoefQ_0, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + HTphiT_b, dd_HTphiT, HTphiQ_b, dd_HTphiQ, HTRn_b, dd_HTRn, & + phiT0_b, dphiT0, phiQ0_b, dphiQ0, Rn0_b, dRn0, & + yg_T, yg_Q, & + yGamma_dTs_phiT, yGamma_dQs_phiQ, & + ydTs_ins, ydqs_ins & + ) + ELSE ! + AcoefH(:) = AcoefH_0(:) + AcoefQ(:) = AcoefQ_0(:) + BcoefH(:) = BcoefH_0(:) + BcoefQ(:) = BcoefQ_0(:) + yg_T(:) = 0. + yg_Q(:) = 0. + yGamma_dTs_phiT(:) = 0. + yGamma_dQs_phiQ(:) = 0. + ydTs_ins(:) = 0. + ydqs_ins(:) = 0. + ENDIF ! (iflag_split .eq. 2) +! + ELSE ! (nsrf .ne. is_oce) + ybeta(1:knon) = 1. + yevap_pot(1:knon) = yevap(1:knon) + AcoefH(:) = AcoefH_0(:) + AcoefQ(:) = AcoefQ_0(:) + BcoefH(:) = BcoefH_0(:) + BcoefQ(:) = BcoefQ_0(:) + yg_T(:) = 0. + yg_Q(:) = 0. + yGamma_dTs_phiT(:) = 0. + yGamma_dQs_phiQ(:) = 0. + ydTs_ins(:) = 0. + ydqs_ins(:) = 0. + ENDIF ! (nsrf .ne. is_oce) +! + CALL wx_pbl_split(knon, nsrf, dtime, ywake_s, ybeta, iflag_split, & + yg_T, yg_Q, & + yGamma_dTs_phiT, yGamma_dQs_phiQ, & + ydTs_ins, ydqs_ins, & + y_flux_t1, y_flux_q1, y_flux_u1, y_flux_v1, & +!!!! HTRn_b, dd_HTRn, HTphiT_b, dd_HTphiT, & + phiQ0_b, phiT0_b, & + y_flux_t1_x, y_flux_t1_w, & + y_flux_q1_x, y_flux_q1_w, & + y_flux_u1_x, y_flux_u1_w, & + y_flux_v1_x, y_flux_v1_w, & + yfluxlat_x, yfluxlat_w, & + y_delta_qsats, & + y_delta_tsurf_new, y_delta_qsurf & + ) +! + CALL wx_pbl_check(knon, dtime, ypplay, ypaprs, ywake_s, ybeta, iflag_split, & + yTs, y_delta_tsurf, & + yqsurf, yTsurf_new, & + y_delta_tsurf_new, y_delta_qsats, & + AcoefH_x, AcoefH_w, & + BcoefH_x, BcoefH_w, & + AcoefH_0, AcoefQ_0, BcoefH_0, BcoefQ_0, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + y_flux_t1, y_flux_q1, & + y_flux_t1_x, y_flux_t1_w, & + y_flux_q1_x, y_flux_q1_w) +! + IF (nsrf .ne. is_oce) THEN + CALL wx_pbl_dts_check(knon, dtime, ypplay, ypaprs, ywake_s, ybeta, iflag_split, & + yTs, y_delta_tsurf, & + yqsurf, yTsurf_new, & + y_delta_qsats, y_delta_tsurf_new, y_delta_qsurf, & + AcoefH_x, AcoefH_w, & + BcoefH_x, BcoefH_w, & + AcoefH_0, AcoefQ_0, BcoefH_0, BcoefQ_0, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + HTphiT_b, dd_HTphiT, HTphiQ_b, dd_HTphiQ, HTRn_b, dd_HTRn, & + phiT0_b, dphiT0, phiQ0_b, dphiQ0, Rn0_b, dRn0, & + yg_T, yg_Q, & + yGamma_dTs_phiT, yGamma_dQs_phiQ, & + ydTs_ins, ydqs_ins, & + y_flux_t1, y_flux_q1, & + y_flux_t1_x, y_flux_t1_w, & + y_flux_q1_x, y_flux_q1_w ) + ENDIF ! (nsrf .ne. is_oce) +! + ELSE ! (iflag_split .ge. 1) + ybeta(1:knon) = 1. + yevap_pot(1:knon) = yevap(1:knon) + ENDIF ! (iflag_split .ge. 1) +! + IF (prt_level >= 10) THEN + print *,'pbl_surface, ybeta , yevap, yevap_pot ', & + ybeta(1:knon) , yevap(1:knon), yevap_pot(1:knon) + ENDIF ! (prt_level >= 10) +! +!>jyg +! + +!!jyg!! A reprendre apres reflexion =============================================== +!!jyg!! +!!jyg!! DO j=1,knon +!!jyg!!!!! nrlmd le 13/06/2011 +!!jyg!! +!!jyg!!!----Diffusion dans le sol dans le cas continental seulement +!!jyg!! IF (nsrf.eq.is_ter) THEN +!!jyg!!!----Calcul du coefficient delta_coeff +!!jyg!! tau_eq(j)=(ywake_s(j)/2.)*(1./max(wake_cstar(j),0.01))*sqrt(0.4/(3.14*max(wake_dens(j),8e-12))) +!!jyg!! +!!jyg!!! delta_coef(j)=dtime/(inertia*sqrt(tau_eq(j))) +!!jyg!! delta_coef(j)=facteur*sqrt(tau_eq(j))/inertia +!!jyg!!! delta_coef(j)=0. +!!jyg!! ELSE +!!jyg!! delta_coef(j)=0. +!!jyg!! ENDIF +!!jyg!! +!!jyg!!!----Calcul de delta_tsurf +!!jyg!! y_delta_tsurf(j)=delta_coef(j)*y_delta_flux_t1(j) +!!jyg!! +!!jyg!!!----Si il n'y a pas des poches... +!!jyg!! IF (wake_cstar(j).le.0.01) THEN +!!jyg!! y_delta_tsurf(j)=0. +!!jyg!! y_delta_flux_t1(j)=0. +!!jyg!! ENDIF +!!jyg!! +!!jyg!!!-----Calcul de ybeta (evap_r\'eelle/evap_potentielle) +!!jyg!!!!!!! jyg le 23/02/2012 +!!jyg!!!!!!! +!!jyg!!!! ybeta(j)=y_flux_q1(j) / & +!!jyg!!!! & (Kech_h(j)*(yq(j,1)-yqsatsurf(j))) +!!jyg!!!!!! ybeta(j)=-1.*yevap(j) / & +!!jyg!!!!!! & (ywake_s(j)*Kech_h_w(j)*(yq_w(j,1)-yqsatsurf_w(j))+(1.-ywake_s(j))*Kech_h_x(j)*(yq_x(j,1)-yqsatsurf_x(j))) +!!jyg!!!!!!! fin jyg +!!jyg!!!!! +!!jyg!! +!!jyg!! ENDDO +!!jyg!! +!!jyg!!!!! fin nrlmd le 13/06/2011 +!!jyg!! + IF (iflag_split .ge. 1) THEN + IF (prt_level >=10) THEN + DO j = 1, knon + print*,'Chx,Chw,Ch', ycdragh_x(j), ycdragh_w(j), ycdragh(j) + print*,'Khx,Khw,Kh', Kech_h_x(j), Kech_h_w(j), Kech_h(j) + print*,'t1x, t1w, t1, t1_ancien', & + & yt_x(j,1), yt_w(j,1), yt(j,1), t(j,1) + print*,'delta_coef,delta_flux,delta_tsurf,tau', delta_coef(j), y_delta_flux_t1(j), y_delta_tsurf(j), tau_eq(j) + ENDDO + + DO j=1,knon + print*,'fluxT_x, fluxT_w, y_flux_t1, fluxQ_x, fluxQ_w, yfluxlat, wakes' & + & , y_flux_t1_x(j), y_flux_t1_w(j), y_flux_t1(j), y_flux_q1_x(j)*RLVTT, y_flux_q1_w(j)*RLVTT, yfluxlat(j), ywake_s(j) + print*,'beta, ytsurf_new ', ybeta(j), ytsurf_new(j) + print*,'inertia, facteur, cstar', inertia, facteur,wake_cstar(j) + ENDDO + ENDIF ! (prt_level >=10) + +!!! jyg le 07/02/2012 + ENDIF ! (iflag_split .ge.1) +!!! + +!!! jyg le 07/02/2012 + IF (iflag_split .eq.0) THEN +!!! +!!! nrlmd & jyg les 02/05/2011, 13/06/2011, 05/02/2012 + CALL climb_hq_up(knon, dtime, yt, yq, & + y_flux_q1, y_flux_t1, ypaprs, ypplay, & +!!! jyg le 07/02/2012 + AcoefH, AcoefQ, BcoefH, BcoefQ, & + CcoefH, CcoefQ, DcoefH, DcoefQ, & + Kcoef_hq, gama_q, gama_h, & +!!! + y_flux_q(:,:), y_flux_t(:,:), y_d_q(:,:), y_d_t(:,:) & +#ifdef ISO + & ,yxt,y_flux_xt1 & + & ,AcoefXT,BcoefXT,CcoefXT,DcoefXT,gama_xt & + & ,y_flux_xt(:,:,:),y_d_xt(:,:,:) & +#endif + & ) + ELSE !(iflag_split .eq.0) + CALL climb_hq_up(knon, dtime, yt_x, yq_x, & + y_flux_q1_x, y_flux_t1_x, ypaprs, ypplay, & +!!! nrlmd le 02/05/2011 + AcoefH_x, AcoefQ_x, BcoefH_x, BcoefQ_x, & + CcoefH_x, CcoefQ_x, DcoefH_x, DcoefQ_x, & + Kcoef_hq_x, gama_q_x, gama_h_x, & +!!! + y_flux_q_x(:,:), y_flux_t_x(:,:), y_d_q_x(:,:), y_d_t_x(:,:) & +#ifdef ISO + & ,yxt_x,y_flux_xt1_x & + & ,AcoefXT_x,BcoefXT_x,CcoefXT_x,DcoefXT_x,gama_xt_x & + & ,y_flux_xt_x(:,:,:),y_d_xt_x(:,:,:) & +#endif + & ) +! + CALL climb_hq_up(knon, dtime, yt_w, yq_w, & + y_flux_q1_w, y_flux_t1_w, ypaprs, ypplay, & +!!! nrlmd le 02/05/2011 + AcoefH_w, AcoefQ_w, BcoefH_w, BcoefQ_w, & + CcoefH_w, CcoefQ_w, DcoefH_w, DcoefQ_w, & + Kcoef_hq_w, gama_q_w, gama_h_w, & +!!! + y_flux_q_w(:,:), y_flux_t_w(:,:), y_d_q_w(:,:), y_d_t_w(:,:) & +#ifdef ISO + & ,yxt_w,y_flux_xt1_w & + & ,AcoefXT_w,BcoefXT_w,CcoefXT_w,DcoefXT_w,gama_xt_w & + & ,y_flux_xt_w(:,:,:),y_d_xt_w(:,:,:) & +#endif + & ) +!!! + ENDIF ! (iflag_split .eq.0) +!!! + +!!! jyg le 07/02/2012 + IF (iflag_split .eq.0) THEN +!!! +!!! nrlmd & jyg les 02/05/2011, 13/06/2011, 05/02/2012 + CALL climb_wind_up(knon, dtime, yu, yv, y_flux_u1, y_flux_v1, & +!!! jyg le 07/02/2012 + AcoefU, AcoefV, BcoefU, BcoefV, & + CcoefU, CcoefV, DcoefU, DcoefV, & + Kcoef_m, & +!!! + y_flux_u, y_flux_v, y_d_u, y_d_v) + y_d_t_diss(:,:)=0. + IF (iflag_pbl>=20 .and. iflag_pbl<30) THEN + CALL yamada_c(knon,dtime,ypaprs,ypplay & + & ,yu,yv,yt,y_d_u,y_d_v,y_d_t,ycdragm,ytke,ycoefm,ycoefh,ycoefq,y_d_t_diss,yustar & + & ,iflag_pbl) + ENDIF +! print*,'yamada_c OK' + + ELSE !(iflag_split .eq.0) + CALL climb_wind_up(knon, dtime, yu_x, yv_x, y_flux_u1_x, y_flux_v1_x, & +!!! nrlmd le 02/05/2011 + AcoefU_x, AcoefV_x, BcoefU_x, BcoefV_x, & + CcoefU_x, CcoefV_x, DcoefU_x, DcoefV_x, & + Kcoef_m_x, & +!!! + y_flux_u_x, y_flux_v_x, y_d_u_x, y_d_v_x) +! + y_d_t_diss_x(:,:)=0. + IF (iflag_pbl>=20 .and. iflag_pbl<30) THEN + CALL yamada_c(knon,dtime,ypaprs,ypplay & + & ,yu_x,yv_x,yt_x,y_d_u_x,y_d_v_x,y_d_t_x,ycdragm_x,ytke_x,ycoefm_x,ycoefh_x & + ,ycoefq_x,y_d_t_diss_x,yustar_x & + & ,iflag_pbl) + ENDIF +! print*,'yamada_c OK' + + CALL climb_wind_up(knon, dtime, yu_w, yv_w, y_flux_u1_w, y_flux_v1_w, & +!!! nrlmd le 02/05/2011 + AcoefU_w, AcoefV_w, BcoefU_w, BcoefV_w, & + CcoefU_w, CcoefV_w, DcoefU_w, DcoefV_w, & + Kcoef_m_w, & +!!! + y_flux_u_w, y_flux_v_w, y_d_u_w, y_d_v_w) +!!! + y_d_t_diss_w(:,:)=0. + IF (iflag_pbl>=20 .and. iflag_pbl<30) THEN + CALL yamada_c(knon,dtime,ypaprs,ypplay & + & ,yu_w,yv_w,yt_w,y_d_u_w,y_d_v_w,y_d_t_w,ycdragm_w,ytke_w,ycoefm_w,ycoefh_w & + ,ycoefq_w,y_d_t_diss_w,yustar_w & + & ,iflag_pbl) + ENDIF +! print*,'yamada_c OK' +! + IF (prt_level >=10) THEN + print *, 'After climbing up, lfuxlat_x, fluxlat_w ', & + yfluxlat_x(1:knon), yfluxlat_w(1:knon) + ENDIF +! + ENDIF ! (iflag_split .eq.0) + + IF (ok_bs) THEN + CALL climb_qbs_up(knon, dtime, yqbs, & + y_flux_bs, ypaprs, ypplay, & + AcoefQBS, BcoefQBS, & + CcoefQBS, DcoefQBS, & + Kcoef_qbs, gama_qbs, & + y_flux_qbs(:,:), y_d_qbs(:,:)) + ENDIF + +!!! +!! +!! DO j = 1, knon +!! y_dflux_t(j) = y_dflux_t(j) * ypct(j) +!! y_dflux_q(j) = y_dflux_q(j) * ypct(j) +!! ENDDO +!! +!**************************************************************************************** +! 13) Transform variables for output format : +! - Decompress +! - Multiply with pourcentage of current surface +! - Cumulate in global variable +! +!**************************************************************************************** + + +!!! jyg le 07/02/2012 + IF (iflag_split.EQ.0) THEN +!!! + DO k = 1, klev + DO j = 1, knon + i = ni(j) + y_d_t_diss(j,k) = y_d_t_diss(j,k) * ypct(j) + y_d_t(j,k) = y_d_t(j,k) * ypct(j) + y_d_q(j,k) = y_d_q(j,k) * ypct(j) + y_d_u(j,k) = y_d_u(j,k) * ypct(j) + y_d_v(j,k) = y_d_v(j,k) * ypct(j) +!FC + IF (nsrf .EQ. is_ter .and. ifl_pbltree .GE. 1) THEN +! if (y_d_u_frein(j,k).ne.0. ) then +! print*, nsrf,'IS_TER ++', y_d_u_frein(j,k)*ypct(j),y_d_u(j,k),j,k +! ENDIF + y_d_u(j,k) =y_d_u(j,k) + y_d_u_frein(j,k)*ypct(j) + y_d_v(j,k) =y_d_v(j,k) + y_d_v_frein(j,k)*ypct(j) + treedrg(i,k,nsrf)=y_treedrg(j,k) + ELSE + treedrg(i,k,nsrf)=0. + ENDIF +!FC + flux_t(i,k,nsrf) = y_flux_t(j,k) + flux_q(i,k,nsrf) = y_flux_q(j,k) + flux_u(i,k,nsrf) = y_flux_u(j,k) + flux_v(i,k,nsrf) = y_flux_v(j,k) + +#ifdef ISO + DO ixt=1,ntraciso + y_d_xt(ixt,j,k) = y_d_xt(ixt,j,k) * ypct(j) + flux_xt(ixt,i,k,nsrf) = y_flux_xt(ixt,j,k) + ENDDO ! DO ixt=1,ntraciso + h1_diag(i)=h1(j) +#endif + + ENDDO + ENDDO + +#ifdef ISO +#ifdef ISOVERIF + if (iso_eau.gt.0) then + call iso_verif_egalite_vect2D( & + y_d_xt,y_d_q, & + 'pbl_surface_mod 2600',ntraciso,klon,klev) + endif +#endif +#endif + + ELSE !(iflag_split .eq.0) + +! Tendances hors poches + DO k = 1, klev + DO j = 1, knon + i = ni(j) + y_d_t_diss_x(j,k) = y_d_t_diss_x(j,k) * ypct(j) + y_d_t_x(j,k) = y_d_t_x(j,k) * ypct(j) + y_d_q_x(j,k) = y_d_q_x(j,k) * ypct(j) + y_d_u_x(j,k) = y_d_u_x(j,k) * ypct(j) + y_d_v_x(j,k) = y_d_v_x(j,k) * ypct(j) + + flux_t_x(i,k,nsrf) = y_flux_t_x(j,k) + flux_q_x(i,k,nsrf) = y_flux_q_x(j,k) + flux_u_x(i,k,nsrf) = y_flux_u_x(j,k) + flux_v_x(i,k,nsrf) = y_flux_v_x(j,k) + +#ifdef ISO + DO ixt=1,ntraciso + y_d_xt_x(ixt,j,k) = y_d_xt_x(ixt,j,k) * ypct(j) + flux_xt_x(ixt,i,k,nsrf) = y_flux_xt_x(ixt,j,k) + ENDDO ! DO ixt=1,ntraciso +#endif + ENDDO + ENDDO + +! Tendances dans les poches + DO k = 1, klev + DO j = 1, knon + i = ni(j) + y_d_t_diss_w(j,k) = y_d_t_diss_w(j,k) * ypct(j) + y_d_t_w(j,k) = y_d_t_w(j,k) * ypct(j) + y_d_q_w(j,k) = y_d_q_w(j,k) * ypct(j) + y_d_u_w(j,k) = y_d_u_w(j,k) * ypct(j) + y_d_v_w(j,k) = y_d_v_w(j,k) * ypct(j) + + flux_t_w(i,k,nsrf) = y_flux_t_w(j,k) + flux_q_w(i,k,nsrf) = y_flux_q_w(j,k) + flux_u_w(i,k,nsrf) = y_flux_u_w(j,k) + flux_v_w(i,k,nsrf) = y_flux_v_w(j,k) + +#ifdef ISO + DO ixt=1,ntraciso + y_d_xt_w(ixt,j,k) = y_d_xt_w(ixt,j,k) * ypct(j) + flux_xt_w(ixt,i,k,nsrf) = y_flux_xt_w(ixt,j,k) + ENDDO ! do ixt=1,ntraciso +#endif + + ENDDO + ENDDO + +! Flux, tendances et Tke moyenne dans la maille + DO k = 1, klev + DO j = 1, knon + i = ni(j) + flux_t(i,k,nsrf) = flux_t_x(i,k,nsrf)+ywake_s(j)*(flux_t_w(i,k,nsrf)-flux_t_x(i,k,nsrf)) + flux_q(i,k,nsrf) = flux_q_x(i,k,nsrf)+ywake_s(j)*(flux_q_w(i,k,nsrf)-flux_q_x(i,k,nsrf)) + flux_u(i,k,nsrf) = flux_u_x(i,k,nsrf)+ywake_s(j)*(flux_u_w(i,k,nsrf)-flux_u_x(i,k,nsrf)) + flux_v(i,k,nsrf) = flux_v_x(i,k,nsrf)+ywake_s(j)*(flux_v_w(i,k,nsrf)-flux_v_x(i,k,nsrf)) +#ifdef ISO + DO ixt=1,ntraciso + flux_xt(ixt,i,k,nsrf) = flux_xt_x(ixt,i,k,nsrf)+ywake_s(j)*(flux_xt_w(ixt,i,k,nsrf)-flux_xt_x(ixt,i,k,nsrf)) + ENDDO ! do ixt=1,ntraciso +#endif + ENDDO + ENDDO + DO j=1,knon + yfluxlat(j)=yfluxlat_x(j)+ywake_s(j)*(yfluxlat_w(j)-yfluxlat_x(j)) + ENDDO + IF (prt_level >=10) THEN + print *,' nsrf, flux_t(:,1,nsrf), flux_t_x(:,1,nsrf), flux_t_w(:,1,nsrf) ', & + nsrf, flux_t(:,1,nsrf), flux_t_x(:,1,nsrf), flux_t_w(:,1,nsrf) + ENDIF + + DO k = 1, klev + DO j = 1, knon + y_d_t_diss(j,k) = y_d_t_diss_x(j,k)+ywake_s(j)*(y_d_t_diss_w(j,k) -y_d_t_diss_x(j,k)) + y_d_t(j,k) = y_d_t_x(j,k)+ywake_s(j)*(y_d_t_w(j,k) -y_d_t_x(j,k)) + y_d_q(j,k) = y_d_q_x(j,k)+ywake_s(j)*(y_d_q_w(j,k) -y_d_q_x(j,k)) + y_d_u(j,k) = y_d_u_x(j,k)+ywake_s(j)*(y_d_u_w(j,k) -y_d_u_x(j,k)) + y_d_v(j,k) = y_d_v_x(j,k)+ywake_s(j)*(y_d_v_w(j,k) -y_d_v_x(j,k)) + ENDDO + ENDDO + + ENDIF ! (iflag_split .eq.0) + + + ! tendencies of blowing snow + IF (ok_bs) THEN + DO k = 1, klev + DO j = 1, knon + i = ni(j) + y_d_qbs(j,k)=y_d_qbs(j,k) * ypct(j) + flux_qbs(i,k,nsrf) = y_flux_qbs(j,k) + ENDDO + ENDDO + ENDIF + + + DO j = 1, knon + i = ni(j) + evap(i,nsrf) = - flux_q(i,1,nsrf) !jyg + if (ok_bs) then ; snowerosion(i,nsrf)=flux_qbs(i,1,nsrf); endif + beta(i,nsrf) = ybeta(j) !jyg + d_ts(i,nsrf) = y_d_ts(j) +!albedo SB >>> + DO k=1,nsw + alb_dir(i,k,nsrf) = yalb_dir_new(j,k) + alb_dif(i,k,nsrf) = yalb_dif_new(j,k) + ENDDO +!albedo SB <<< + snow(i,nsrf) = ysnow(j) + qsurf(i,nsrf) = yqsurf(j) + z0m(i,nsrf) = yz0m(j) + z0h(i,nsrf) = yz0h(j) + fluxlat(i,nsrf) = yfluxlat(j) + agesno(i,nsrf) = yagesno(j) + cdragh(i) = cdragh(i) + ycdragh(j)*ypct(j) + cdragm(i) = cdragm(i) + ycdragm(j)*ypct(j) + dflux_t(i) = dflux_t(i) + y_dflux_t(j)*ypct(j) + dflux_q(i) = dflux_q(i) + y_dflux_q(j)*ypct(j) +#ifdef ISO + DO ixt=1,niso + xtsnow(ixt,i,nsrf) = yxtsnow(ixt,j) + ENDDO + DO ixt=1,ntraciso + xtevap(ixt,i,nsrf) = - flux_xt(ixt,i,1,nsrf) + dflux_xt(ixt,i) = dflux_xt(ixt,i) + y_dflux_xt(ixt,j)*ypct(j) + ENDDO + IF (nsrf == is_lic) THEN + DO ixt=1,niso + Rland_ice(ixt,i) = yRland_ice(ixt,j) + ENDDO + ENDIF !IF (nsrf == is_lic) THEN + IF (nsrf == is_ter) THEN + DO ixt=1,niso + xtriverflow(ixt,i) = yxtriverflow(ixt,j) + xtcoastalflow(ixt,i)= yxtcoastalflow(ixt,j) + Rsol(ixt,i) = yRsol(ixt,j) + ENDDO + ENDIF !IF (nsrf == is_ter) THEN +#ifdef ISOVERIF + IF (iso_eau.GT.0) THEN + CALL iso_verif_egalite_choix(Rland_ice(iso_eau,i),1.0, & + & 'pbl_surf_mod 3506',errmax,errmaxrel) + CALL iso_verif_egalite_choix(Rsol(iso_eau,i),1.0, & + & 'pbl_surf_mod 3508',errmax,errmaxrel) + ENDIF !if (iso_eau.gt.0) then +#endif +#endif + ENDDO + +! print*,'Dans pbl OK2' + +!!! jyg le 07/02/2012 + IF (iflag_split .ge.1) THEN +!!! +!!! nrlmd le 02/05/2011 + DO j = 1, knon + i = ni(j) + fluxlat_x(i,nsrf) = yfluxlat_x(j) + fluxlat_w(i,nsrf) = yfluxlat_w(j) +!!! +!!! nrlmd le 13/06/2011 +!!jyg20170131 delta_tsurf(i,nsrf)=y_delta_tsurf(j)*ypct(j) +!!jyg20210118 delta_tsurf(i,nsrf)=y_delta_tsurf(j) + delta_tsurf(i,nsrf)=y_delta_tsurf_new(j) +! + delta_qsurf(i) = delta_qsurf(i) + y_delta_qsurf(j)*ypct(j) +! + cdragh_x(i) = cdragh_x(i) + ycdragh_x(j)*ypct(j) + cdragh_w(i) = cdragh_w(i) + ycdragh_w(j)*ypct(j) + cdragm_x(i) = cdragm_x(i) + ycdragm_x(j)*ypct(j) + cdragm_w(i) = cdragm_w(i) + ycdragm_w(j)*ypct(j) + kh(i) = kh(i) + Kech_h(j)*ypct(j) + kh_x(i) = kh_x(i) + Kech_h_x(j)*ypct(j) + kh_w(i) = kh_w(i) + Kech_h_w(j)*ypct(j) +!!! + ENDDO +!!! + ENDIF ! (iflag_split .ge.1) +!!! +!!! nrlmd le 02/05/2011 +!!jyg le 20/02/2011 +!! tke_x(:,:,nsrf)=0. +!! tke_w(:,:,nsrf)=0. +!!jyg le 20/02/2011 +!! DO k = 1, klev+1 +!! DO j = 1, knon +!! i = ni(j) +!! wake_dltke(i,k,nsrf) = ytke_w(j,k) - ytke_x(j,k) +!! tke(i,k,nsrf) = ytke_x(j,k) + ywake_s(j)*wake_dltke(i,k,nsrf) +!! ENDDO +!! ENDDO +!!jyg le 20/02/2011 +!! DO k = 1, klev+1 +!! DO j = 1, knon +!! i = ni(j) +!! tke(i,k,nsrf)=(1.-ywake_s(j))*tke_x(i,k,nsrf)+ywake_s(j)*tke_w(i,k,nsrf) +!! ENDDO +!! ENDDO +!!! + IF (iflag_split .eq.0) THEN + wake_dltke(:,:,nsrf) = 0. + DO k = 1, klev+1 + DO j = 1, knon + i = ni(j) +!jyg< +!! tke(i,k,nsrf) = ytke(j,k) +!! tke(i,k,is_ave) = tke(i,k,is_ave) + ytke(j,k)*ypct(j) + tke_x(i,k,nsrf) = ytke(j,k) + tke_x(i,k,is_ave) = tke_x(i,k,is_ave) + ytke(j,k)*ypct(j) + eps_x(i,k,nsrf) = yeps(j,k) + eps_x(i,k,is_ave) = eps_x(i,k,is_ave) + yeps(j,k)*ypct(j) +!>jyg + ENDDO + ENDDO + + ELSE ! (iflag_split .eq.0) + DO k = 1, klev+1 + DO j = 1, knon + i = ni(j) + wake_dltke(i,k,nsrf) = ytke_w(j,k) - ytke_x(j,k) +!jyg< +!! tke(i,k,nsrf) = ytke_x(j,k) + ywake_s(j)*wake_dltke(i,k,nsrf) +!! tke(i,k,is_ave) = tke(i,k,is_ave) + tke(i,k,nsrf)*ypct(j) + tke_x(i,k,nsrf) = ytke_x(j,k) + tke_x(i,k,is_ave) = tke_x(i,k,is_ave) + tke_x(i,k,nsrf)*ypct(j) + eps_x(i,k,nsrf) = yeps_x(j,k) + eps_x(i,k,is_ave) = eps_x(i,k,is_ave) + eps_x(i,k,nsrf)*ypct(j) + wake_dltke(i,k,is_ave) = wake_dltke(i,k,is_ave) + wake_dltke(i,k,nsrf)*ypct(j) + + +!>jyg + ENDDO + ENDDO + ENDIF ! (iflag_split .eq.0) +!!! + DO k = 2, klev + DO j = 1, knon + i = ni(j) + zcoefh(i,k,nsrf) = ycoefh(j,k) + zcoefm(i,k,nsrf) = ycoefm(j,k) + zcoefh(i,k,is_ave) = zcoefh(i,k,is_ave) + ycoefh(j,k)*ypct(j) + zcoefm(i,k,is_ave) = zcoefm(i,k,is_ave) + ycoefm(j,k)*ypct(j) + ENDDO + ENDDO + +! print*,'Dans pbl OK3' + + IF ( nsrf .EQ. is_ter ) THEN + DO j = 1, knon + i = ni(j) + qsol(i) = yqsol(j) +#ifdef ISO + runoff_diag(i)=yrunoff_diag(j) + DO ixt=1,niso + xtsol(ixt,i) = yxtsol(ixt,j) + xtrunoff_diag(ixt,i)=yxtrunoff_diag(ixt,j) + ENDDO +#endif + ENDDO + ENDIF + +!jyg< +!! ftsoil(:,:,nsrf) = 0. +!>jyg + DO k = 1, nsoilmx + DO j = 1, knon + i = ni(j) + ftsoil(i, k, nsrf) = ytsoil(j,k) + ENDDO + ENDDO + +#ifdef ISO +#ifdef ISOVERIF + !write(*,*) 'pbl_surface 2858' + DO i = 1, klon + DO ixt=1,niso + call iso_verif_noNaN(xtsol(ixt,i),'pbl_surface 1405') + ENDDO + ENDDO +#endif +#ifdef ISOVERIF + IF (iso_eau.gt.0) THEN + call iso_verif_egalite_vect2D( & + y_d_xt,y_d_q, & + 'pbl_surface_mod 1261',ntraciso,klon,klev) + ENDIF !if (iso_eau.gt.0) then +#endif +#endif +!!! jyg le 07/02/2012 + IF (iflag_split .ge.1) THEN +!!! +!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012 + DO k = 1, klev + DO j = 1, knon + i = ni(j) + d_t_diss_x(i,k) = d_t_diss_x(i,k) + y_d_t_diss_x(j,k) + d_t_x(i,k) = d_t_x(i,k) + y_d_t_x(j,k) + d_q_x(i,k) = d_q_x(i,k) + y_d_q_x(j,k) + d_u_x(i,k) = d_u_x(i,k) + y_d_u_x(j,k) + d_v_x(i,k) = d_v_x(i,k) + y_d_v_x(j,k) +! + d_t_diss_w(i,k) = d_t_diss_w(i,k) + y_d_t_diss_w(j,k) + d_t_w(i,k) = d_t_w(i,k) + y_d_t_w(j,k) + d_q_w(i,k) = d_q_w(i,k) + y_d_q_w(j,k) + d_u_w(i,k) = d_u_w(i,k) + y_d_u_w(j,k) + d_v_w(i,k) = d_v_w(i,k) + y_d_v_w(j,k) +#ifdef ISO + DO ixt=1,ntraciso + d_xt_x(ixt,i,k) = d_xt_x(ixt,i,k) + y_d_xt_x(ixt,j,k) + d_xt_w(ixt,i,k) = d_xt_w(ixt,i,k) + y_d_xt_w(ixt,j,k) + ENDDO ! DO ixt=1,ntraciso +#endif + +! +!! d_wake_dlt(i,k) = d_wake_dlt(i,k) + y_d_t_w(i,k)-y_d_t_x(i,k) +!! d_wake_dlq(i,k) = d_wake_dlq(i,k) + y_d_q_w(i,k)-y_d_q_x(i,k) + ENDDO + ENDDO +!!! + ENDIF ! (iflag_split .ge.1) +!!! + + DO k = 1, klev + DO j = 1, knon + i = ni(j) + d_t_diss(i,k) = d_t_diss(i,k) + y_d_t_diss(j,k) + d_t(i,k) = d_t(i,k) + y_d_t(j,k) + d_q(i,k) = d_q(i,k) + y_d_q(j,k) +#ifdef ISO + DO ixt=1,ntraciso + d_xt(ixt,i,k) = d_xt(ixt,i,k) + y_d_xt(ixt,j,k) + ENDDO !DO ixt=1,ntraciso +#endif + d_u(i,k) = d_u(i,k) + y_d_u(j,k) + d_v(i,k) = d_v(i,k) + y_d_v(j,k) + ENDDO + ENDDO + + + IF (ok_bs) THEN + DO k = 1, klev + DO j = 1, knon + i = ni(j) + d_qbs(i,k) = d_qbs(i,k) + y_d_qbs(j,k) + ENDDO + ENDDO + ENDIF + +#ifdef ISO +#ifdef ISOVERIF +! write(*,*) 'd_q,d_xt(iso_eau,554,19)=',d_q(554,19),d_xt(iso_eau,554,19) +! write(*,*) 'pbl_surface 2929: d_q,d_xt(iso_eau,2,1)=',d_q(2,1),d_xt(iso_eau,2,1) +! write(*,*) 'y_d_q,y_d_xt(iso_eau,2,1)=',y_d_q(2,1),y_d_xt(iso_eau,2,1) +! write(*,*) 'iso_eau.gt.0=',iso_eau.gt.0 + call iso_verif_noNaN_vect2D( & + & d_xt, & + & 'pbl_surface 1385',ntraciso,klon,klev) + IF (iso_eau >= 0) THEN + call iso_verif_egalite_vect2D( & + y_d_xt,y_d_q, & + 'pbl_surface_mod 2945',ntraciso,klon,klev) + call iso_verif_egalite_vect2D( & + d_xt,d_q, & + 'pbl_surface_mod 1276',ntraciso,klon,klev) + ENDIF !IF (iso_eau >= 0) THEN +#endif +#endif + +! print*,'Dans pbl OK4' + + IF (prt_level >=10) THEN + print *, 'pbl_surface tendencies for w: d_t_w, d_t_x, d_t ', & + d_t_w(1:knon,1), d_t_x(1:knon,1), d_t(1:knon,1) + ENDIF + + if (nsrf == is_oce .and. activate_ocean_skin >= 1) then + delta_sal = missing_val + ds_ns = missing_val + dt_ns = missing_val + delta_sst = missing_val + dter = missing_val + dser = missing_val + tkt = missing_val + tks = missing_val + taur = missing_val + sss = missing_val + + delta_sal(ni(:knon)) = ydelta_sal(:knon) + ds_ns(ni(:knon)) = yds_ns(:knon) + dt_ns(ni(:knon)) = ydt_ns(:knon) + delta_sst(ni(:knon)) = ydelta_sst(:knon) + dter(ni(:knon)) = ydter(:knon) + dser(ni(:knon)) = ydser(:knon) + tkt(ni(:knon)) = ytkt(:knon) + tks(ni(:knon)) = ytks(:knon) + taur(ni(:knon)) = ytaur(:knon) + sss(ni(:knon)) = ysss(:knon) + + if (activate_ocean_skin == 2 .and. type_ocean == "couple") then + dt_ds = missing_val + dt_ds(ni(:knon)) = ydt_ds(:knon) + end if + end if + + +!**************************************************************************************** +! 14) Calculate the temperature and relative humidity at 2m and the wind at 10m +! Call HBTM +! +!**************************************************************************************** +!!! +! +#undef T2m +#define T2m +#ifdef T2m +! Calculations of diagnostic t,q at 2m and u, v at 10m + +! print*,'Dans pbl OK41' +! print*,'tair1,yt(:,1),y_d_t(:,1)' +! print*, tair1,yt(:,1),y_d_t(:,1) +!!! jyg le 07/02/2012 + IF (iflag_split .eq.0) THEN + DO j=1, knon + uzon(j) = yu(j,1) + y_d_u(j,1) + vmer(j) = yv(j,1) + y_d_v(j,1) + tair1(j) = yt(j,1) + y_d_t(j,1) + y_d_t_diss(j,1) + qair1(j) = yq(j,1) + y_d_q(j,1) + zgeo1(j) = RD * tair1(j) / (0.5*(ypaprs(j,1)+ypplay(j,1))) & + * (ypaprs(j,1)-ypplay(j,1)) + tairsol(j) = yts(j) + y_d_ts(j) + qairsol(j) = yqsurf(j) + ENDDO + ELSE ! (iflag_split .eq.0) + DO j=1, knon + uzon_x(j) = yu_x(j,1) + y_d_u_x(j,1) + vmer_x(j) = yv_x(j,1) + y_d_v_x(j,1) + tair1_x(j) = yt_x(j,1) + y_d_t_x(j,1) + y_d_t_diss_x(j,1) + qair1_x(j) = yq_x(j,1) + y_d_q_x(j,1) + zgeo1_x(j) = RD * tair1_x(j) / (0.5*(ypaprs(j,1)+ypplay(j,1))) & + * (ypaprs(j,1)-ypplay(j,1)) + tairsol(j) = yts(j) + y_d_ts(j) +!! tairsol_x(j) = tairsol(j) - ywake_s(j)*y_delta_tsurf(j) + tairsol_x(j) = tairsol(j) - ywake_s(j)*y_delta_tsurf_new(j) + qairsol(j) = yqsurf(j) + ENDDO + DO j=1, knon + uzon_w(j) = yu_w(j,1) + y_d_u_w(j,1) + vmer_w(j) = yv_w(j,1) + y_d_v_w(j,1) + tair1_w(j) = yt_w(j,1) + y_d_t_w(j,1) + y_d_t_diss_w(j,1) + qair1_w(j) = yq_w(j,1) + y_d_q_w(j,1) + zgeo1_w(j) = RD * tair1_w(j) / (0.5*(ypaprs(j,1)+ypplay(j,1))) & + * (ypaprs(j,1)-ypplay(j,1)) + tairsol_w(j) = tairsol(j) + (1.- ywake_s(j))*y_delta_tsurf(j) + qairsol(j) = yqsurf(j) + ENDDO +!!! + ENDIF ! (iflag_split .eq.0) +!!! + DO j=1, knon +! i = ni(j) +! yz0h_oupas(j) = yz0m(j) +! IF(nsrf.EQ.is_oce) THEN +! yz0h_oupas(j) = z0m(i,nsrf) +! ENDIF + psfce(j)=ypaprs(j,1) + patm(j)=ypplay(j,1) + ENDDO + + IF (iflag_pbl_surface_t2m_bug==1) THEN + yz0h_oupas(1:knon)=yz0m(1:knon) + ELSE + yz0h_oupas(1:knon)=yz0h(1:knon) + ENDIF + +! print*,'Dans pbl OK42A' +! print*,'tair1,yt(:,1),y_d_t(:,1)' +! print*, tair1,yt(:,1),y_d_t(:,1) + +! Calculate the temperature and relative humidity at 2m and the wind at 10m +!!! jyg le 07/02/2012 + IF (iflag_split .eq.0) THEN + IF (iflag_new_t2mq2m==1) THEN + CALL stdlevvarn(klon, knon, nsrf, zxli, & + uzon, vmer, tair1, qair1, zgeo1, & + tairsol, qairsol, yz0m, yz0h_oupas, psfce, patm, & + yt2m, yq2m, yt10m, yq10m, yu10m, yustar, & + yn2mout(:, nsrf, :)) + ELSE + CALL stdlevvar(klon, knon, nsrf, zxli, & + uzon, vmer, tair1, qair1, zgeo1, & + tairsol, qairsol, yz0m, yz0h_oupas, psfce, patm, & + yt2m, yq2m, yt10m, yq10m, yu10m, yustar, ypblh, rain_f, zxtsol) + ENDIF + ELSE !(iflag_split .eq.0) + IF (iflag_new_t2mq2m==1) THEN + CALL stdlevvarn(klon, knon, nsrf, zxli, & + uzon_x, vmer_x, tair1_x, qair1_x, zgeo1_x, & + tairsol_x, qairsol, yz0m, yz0h_oupas, psfce, patm, & + yt2m_x, yq2m_x, yt10m_x, yq10m_x, yu10m_x, yustar_x, & + yn2mout_x(:, nsrf, :)) + CALL stdlevvarn(klon, knon, nsrf, zxli, & + uzon_w, vmer_w, tair1_w, qair1_w, zgeo1_w, & + tairsol_w, qairsol, yz0m, yz0h_oupas, psfce, patm, & + yt2m_w, yq2m_w, yt10m_w, yq10m_w, yu10m_w, yustar_w, & + yn2mout_w(:, nsrf, :)) + ELSE + CALL stdlevvar(klon, knon, nsrf, zxli, & + uzon_x, vmer_x, tair1_x, qair1_x, zgeo1_x, & + tairsol_x, qairsol, yz0m, yz0h_oupas, psfce, patm, & + yt2m_x, yq2m_x, yt10m_x, yq10m_x, yu10m_x, yustar_x, ypblh_x, rain_f, zxtsol) + CALL stdlevvar(klon, knon, nsrf, zxli, & + uzon_w, vmer_w, tair1_w, qair1_w, zgeo1_w, & + tairsol_w, qairsol, yz0m, yz0h_oupas, psfce, patm, & + yt2m_w, yq2m_w, yt10m_w, yq10m_w, yu10m_w, yustar_w, ypblh_w, rain_f, zxtsol) + ENDIF +!!! + ENDIF ! (iflag_split .eq.0) +!!! +!!! jyg le 07/02/2012 + IF (iflag_split .eq.0) THEN + DO j=1, knon + i = ni(j) + t2m(i,nsrf)=yt2m(j) + q2m(i,nsrf)=yq2m(j) + ! u10m, v10m : composantes du vent a 10m sans spirale de Ekman + ustar(i,nsrf)=yustar(j) + u10m(i,nsrf)=(yu10m(j) * uzon(j))/max(SQRT(uzon(j)**2+vmer(j)**2), smallestreal) + v10m(i,nsrf)=(yu10m(j) * vmer(j))/max(SQRT(uzon(j)**2+vmer(j)**2), smallestreal) +! + DO k = 1, 6 + n2mout(i,nsrf,k) = yn2mout(j,nsrf,k) + END DO +! + ENDDO + ELSE !(iflag_split .eq.0) + DO j=1, knon + i = ni(j) + t2m_x(i,nsrf)=yt2m_x(j) + q2m_x(i,nsrf)=yq2m_x(j) + ! u10m, v10m : composantes du vent a 10m sans spirale de Ekman + ustar_x(i,nsrf)=yustar_x(j) + u10m_x(i,nsrf)=(yu10m_x(j) * uzon_x(j))/max(SQRT(uzon_x(j)**2+vmer_x(j)**2), smallestreal) + v10m_x(i,nsrf)=(yu10m_x(j) * vmer_x(j))/max(SQRT(uzon_x(j)**2+vmer_x(j)**2), smallestreal) +! + DO k = 1, 6 + n2mout_x(i,nsrf,k) = yn2mout_x(j,nsrf,k) + END DO +! + ENDDO + DO j=1, knon + i = ni(j) + t2m_w(i,nsrf)=yt2m_w(j) + q2m_w(i,nsrf)=yq2m_w(j) + ! u10m, v10m : composantes du vent a 10m sans spirale de Ekman + ustar_w(i,nsrf)=yustar_w(j) + u10m_w(i,nsrf)=(yu10m_w(j) * uzon_w(j))/max(SQRT(uzon_w(j)**2+vmer_w(j)**2), smallestreal) + v10m_w(i,nsrf)=(yu10m_w(j) * vmer_w(j))/max(SQRT(uzon_w(j)**2+vmer_w(j)**2), smallestreal) +! + ustar(i,nsrf) = ustar_x(i,nsrf) + wake_s(i)*(ustar_w(i,nsrf)-ustar_x(i,nsrf)) + u10m(i,nsrf) = u10m_x(i,nsrf) + wake_s(i)*(u10m_w(i,nsrf)-u10m_x(i,nsrf)) + v10m(i,nsrf) = v10m_x(i,nsrf) + wake_s(i)*(v10m_w(i,nsrf)-v10m_x(i,nsrf)) +! + DO k = 1, 6 + n2mout_w(i,nsrf,k) = yn2mout_w(j,nsrf,k) + END DO +! + ENDDO +!!! + ENDIF ! (iflag_split .eq.0) +!!! + +! print*,'Dans pbl OK43' +!IM Calcule de l'humidite relative a 2m (rh2m) pour diagnostique +!IM Ajoute dependance type surface + IF (thermcep) THEN +!!! jyg le 07/02/2012 + IF (iflag_split .eq.0) THEN + DO j = 1, knon + i=ni(j) + zdelta1 = MAX(0.,SIGN(1., rtt-yt2m(j) )) + zx_qs1 = r2es * FOEEW(yt2m(j),zdelta1)/paprs(i,1) + zx_qs1 = MIN(0.5,zx_qs1) + zcor1 = 1./(1.-RETV*zx_qs1) + zx_qs1 = zx_qs1*zcor1 + + rh2m(i) = rh2m(i) + yq2m(j)/zx_qs1 * pctsrf(i,nsrf) + qsat2m(i) = qsat2m(i) + zx_qs1 * pctsrf(i,nsrf) + ENDDO + ELSE ! (iflag_split .eq.0) + DO j = 1, knon + i=ni(j) + zdelta1 = MAX(0.,SIGN(1., rtt-yt2m_x(j) )) + zx_qs1 = r2es * FOEEW(yt2m_x(j),zdelta1)/paprs(i,1) + zx_qs1 = MIN(0.5,zx_qs1) + zcor1 = 1./(1.-RETV*zx_qs1) + zx_qs1 = zx_qs1*zcor1 + + rh2m_x(i) = rh2m_x(i) + yq2m_x(j)/zx_qs1 * pctsrf(i,nsrf) + qsat2m_x(i) = qsat2m_x(i) + zx_qs1 * pctsrf(i,nsrf) + ENDDO + DO j = 1, knon + i=ni(j) + zdelta1 = MAX(0.,SIGN(1., rtt-yt2m_w(j) )) + zx_qs1 = r2es * FOEEW(yt2m_w(j),zdelta1)/paprs(i,1) + zx_qs1 = MIN(0.5,zx_qs1) + zcor1 = 1./(1.-RETV*zx_qs1) + zx_qs1 = zx_qs1*zcor1 + + rh2m_w(i) = rh2m_w(i) + yq2m_w(j)/zx_qs1 * pctsrf(i,nsrf) + qsat2m_w(i) = qsat2m_w(i) + zx_qs1 * pctsrf(i,nsrf) + ENDDO +!!! + ENDIF ! (iflag_split .eq.0) +!!! + ENDIF +! + IF (prt_level >=10) THEN + print *, 'T2m, q2m, RH2m ', & + t2m(1:knon,:), q2m(1:knon,:), rh2m(1:knon) + ENDIF + +! print*,'OK pbl 5' +! +!!! jyg le 07/02/2012 + IF (iflag_split .eq.0) THEN + CALL hbtm(knon, ypaprs, ypplay, & + yt2m,yt10m,yq2m,yq10m,yustar,ywstar, & + y_flux_t,y_flux_q,yu,yv,yt,yq, & + ypblh,ycapCL,yoliqCL,ycteiCL,ypblT, & + ytherm,ytrmb1,ytrmb2,ytrmb3,ylcl) + IF (prt_level >=10) THEN + print *,' Arg. de HBTM: yt2m ',yt2m(1:knon) + print *,' Arg. de HBTM: yt10m ',yt10m(1:knon) + print *,' Arg. de HBTM: yq2m ',yq2m(1:knon) + print *,' Arg. de HBTM: yq10m ',yq10m(1:knon) + print *,' Arg. de HBTM: yustar ',yustar(1:knon) + print *,' Arg. de HBTM: y_flux_t ',y_flux_t(1:knon,:) + print *,' Arg. de HBTM: y_flux_q ',y_flux_q(1:knon,:) + print *,' Arg. de HBTM: yu ',yu(1:knon,:) + print *,' Arg. de HBTM: yv ',yv(1:knon,:) + print *,' Arg. de HBTM: yt ',yt(1:knon,:) + print *,' Arg. de HBTM: yq ',yq(1:knon,:) + ENDIF + ELSE ! (iflag_split .eq.0) + CALL HBTM(knon, ypaprs, ypplay, & + yt2m_x,yt10m_x,yq2m_x,yq10m_x,yustar_x,ywstar_x, & + y_flux_t_x,y_flux_q_x,yu_x,yv_x,yt_x,yq_x, & + ypblh_x,ycapCL_x,yoliqCL_x,ycteiCL_x,ypblT_x, & + ytherm_x,ytrmb1_x,ytrmb2_x,ytrmb3_x,ylcl_x) + IF (prt_level >=10) THEN + print *,' Arg. de HBTM: yt2m_x ',yt2m_x(1:knon) + print *,' Arg. de HBTM: yt10m_x ',yt10m_x(1:knon) + print *,' Arg. de HBTM: yq2m_x ',yq2m_x(1:knon) + print *,' Arg. de HBTM: yq10m_x ',yq10m_x(1:knon) + print *,' Arg. de HBTM: yustar_x ',yustar_x(1:knon) + print *,' Arg. de HBTM: y_flux_t_x ',y_flux_t_x(1:knon,:) + print *,' Arg. de HBTM: y_flux_q_x ',y_flux_q_x(1:knon,:) + print *,' Arg. de HBTM: yu_x ',yu_x(1:knon,:) + print *,' Arg. de HBTM: yv_x ',yv_x(1:knon,:) + print *,' Arg. de HBTM: yt_x ',yt_x(1:knon,:) + print *,' Arg. de HBTM: yq_x ',yq_x(1:knon,:) + ENDIF + CALL HBTM(knon, ypaprs, ypplay, & + yt2m_w,yt10m_w,yq2m_w,yq10m_w,yustar_w,ywstar_w, & + y_flux_t_w,y_flux_q_w,yu_w,yv_w,yt_w,yq_w, & + ypblh_w,ycapCL_w,yoliqCL_w,ycteiCL_w,ypblT_w, & + ytherm_w,ytrmb1_w,ytrmb2_w,ytrmb3_w,ylcl_w) +!!! + ENDIF ! (iflag_split .eq.0) +!!! + +!!! jyg le 07/02/2012 + IF (iflag_split .eq.0) THEN +!!! + DO j=1, knon + i = ni(j) + pblh(i,nsrf) = ypblh(j) + wstar(i,nsrf) = ywstar(j) + plcl(i,nsrf) = ylcl(j) + capCL(i,nsrf) = ycapCL(j) + oliqCL(i,nsrf) = yoliqCL(j) + cteiCL(i,nsrf) = ycteiCL(j) + pblT(i,nsrf) = ypblT(j) + therm(i,nsrf) = ytherm(j) + trmb1(i,nsrf) = ytrmb1(j) + trmb2(i,nsrf) = ytrmb2(j) + trmb3(i,nsrf) = ytrmb3(j) + ENDDO + IF (prt_level >=10) THEN + print *, 'After HBTM: pblh ', pblh(1:knon,:) + print *, 'After HBTM: plcl ', plcl(1:knon,:) + print *, 'After HBTM: cteiCL ', cteiCL(1:knon,:) + ENDIF + ELSE !(iflag_split .eq.0) + DO j=1, knon + i = ni(j) + pblh_x(i,nsrf) = ypblh_x(j) + wstar_x(i,nsrf) = ywstar_x(j) + plcl_x(i,nsrf) = ylcl_x(j) + capCL_x(i,nsrf) = ycapCL_x(j) + oliqCL_x(i,nsrf) = yoliqCL_x(j) + cteiCL_x(i,nsrf) = ycteiCL_x(j) + pblT_x(i,nsrf) = ypblT_x(j) + therm_x(i,nsrf) = ytherm_x(j) + trmb1_x(i,nsrf) = ytrmb1_x(j) + trmb2_x(i,nsrf) = ytrmb2_x(j) + trmb3_x(i,nsrf) = ytrmb3_x(j) + ENDDO + IF (prt_level >=10) THEN + print *, 'After HBTM: pblh_x ', pblh_x(1:knon,:) + print *, 'After HBTM: plcl_x ', plcl_x(1:knon,:) + print *, 'After HBTM: cteiCL_x ', cteiCL_x(1:knon,:) + ENDIF + DO j=1, knon + i = ni(j) + pblh_w(i,nsrf) = ypblh_w(j) + wstar_w(i,nsrf) = ywstar_w(j) + plcl_w(i,nsrf) = ylcl_w(j) + capCL_w(i,nsrf) = ycapCL_w(j) + oliqCL_w(i,nsrf) = yoliqCL_w(j) + cteiCL_w(i,nsrf) = ycteiCL_w(j) + pblT_w(i,nsrf) = ypblT_w(j) + therm_w(i,nsrf) = ytherm_w(j) + trmb1_w(i,nsrf) = ytrmb1_w(j) + trmb2_w(i,nsrf) = ytrmb2_w(j) + trmb3_w(i,nsrf) = ytrmb3_w(j) + ENDDO + IF (prt_level >=10) THEN + print *, 'After HBTM: pblh_w ', pblh_w(1:knon,:) + print *, 'After HBTM: plcl_w ', plcl_w(1:knon,:) + print *, 'After HBTM: cteiCL_w ', cteiCL_w(1:knon,:) + ENDIF +!!! + ENDIF ! (iflag_split .eq.0) +!!! + +! print*,'OK pbl 6' +#else +! T2m not defined +! No calculation + PRINT*,' Warning !!! No T2m calculation. Output is set to zero.' +#endif + +!**************************************************************************************** +! 15) End of loop over different surfaces +! +!**************************************************************************************** + ENDDO loop_nbsrf +! +!---------------------------------------------------------------------------------------- +! Reset iflag_split +! + iflag_split=iflag_split_ref + +#ifdef ISO +#ifdef ISOVERIF +! write(*,*) 'pbl_surface tmp 3249: d_q,d_xt(iso_eau,2,1)=',d_q(2,1),d_xt(iso_eau,2,1) + IF (iso_eau >= 0) THEN + call iso_verif_egalite_vect2D( & + d_xt,d_q, & + 'pbl_surface_mod 1276',ntraciso,klon,klev) + ENDIF !IF (iso_eau >= 0) THEN +#endif +#endif + +!**************************************************************************************** +! 16) Calculate the mean value over all sub-surfaces for some variables +! +!**************************************************************************************** + + z0m(:,nbsrf+1) = 0.0 + z0h(:,nbsrf+1) = 0.0 + DO nsrf = 1, nbsrf + DO i = 1, klon + z0m(i,nbsrf+1) = z0m(i,nbsrf+1) + z0m(i,nsrf)*pctsrf(i,nsrf) + z0h(i,nbsrf+1) = z0h(i,nbsrf+1) + z0h(i,nsrf)*pctsrf(i,nsrf) + ENDDO + ENDDO + +! print*,'OK pbl 7' + zxfluxt(:,:) = 0.0 ; zxfluxq(:,:) = 0.0 + zxfluxu(:,:) = 0.0 ; zxfluxv(:,:) = 0.0 + zxfluxt_x(:,:) = 0.0 ; zxfluxq_x(:,:) = 0.0 + zxfluxu_x(:,:) = 0.0 ; zxfluxv_x(:,:) = 0.0 + zxfluxt_w(:,:) = 0.0 ; zxfluxq_w(:,:) = 0.0 + zxfluxu_w(:,:) = 0.0 ; zxfluxv_w(:,:) = 0.0 +#ifdef ISO + zxfluxxt(:,:,:) = 0.0 + zxfluxxt_x(:,:,:) = 0.0 + zxfluxxt_w(:,:,:) = 0.0 +#endif + + +!!! jyg le 07/02/2012 + IF (iflag_split .ge.1) THEN +!!! +!!! nrlmd & jyg les 02/05/2011, 05/02/2012 + + DO nsrf = 1, nbsrf + DO k = 1, klev + DO i = 1, klon + zxfluxt_x(i,k) = zxfluxt_x(i,k) + flux_t_x(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxq_x(i,k) = zxfluxq_x(i,k) + flux_q_x(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxu_x(i,k) = zxfluxu_x(i,k) + flux_u_x(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxv_x(i,k) = zxfluxv_x(i,k) + flux_v_x(i,k,nsrf) * pctsrf(i,nsrf) +! + zxfluxt_w(i,k) = zxfluxt_w(i,k) + flux_t_w(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxq_w(i,k) = zxfluxq_w(i,k) + flux_q_w(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxu_w(i,k) = zxfluxu_w(i,k) + flux_u_w(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxv_w(i,k) = zxfluxv_w(i,k) + flux_v_w(i,k,nsrf) * pctsrf(i,nsrf) +#ifdef ISO + DO ixt=1,ntraciso + zxfluxxt_x(ixt,i,k) = zxfluxxt_x(ixt,i,k) + flux_xt_x(ixt,i,k,nsrf) * pctsrf(i,nsrf) + zxfluxxt_w(ixt,i,k) = zxfluxxt_w(ixt,i,k) + flux_xt_w(ixt,i,k,nsrf) * pctsrf(i,nsrf) + ENDDO ! DO ixt=1,ntraciso +#endif + ENDDO + ENDDO + ENDDO + + DO i = 1, klon + zxsens_x(i) = - zxfluxt_x(i,1) + zxsens_w(i) = - zxfluxt_w(i,1) + ENDDO +!!! + ENDIF ! (iflag_split .ge.1) +!!! + + DO nsrf = 1, nbsrf + DO k = 1, klev + DO i = 1, klon + zxfluxt(i,k) = zxfluxt(i,k) + flux_t(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxq(i,k) = zxfluxq(i,k) + flux_q(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxu(i,k) = zxfluxu(i,k) + flux_u(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxv(i,k) = zxfluxv(i,k) + flux_v(i,k,nsrf) * pctsrf(i,nsrf) +#ifdef ISO + DO ixt=1,niso + zxfluxxt(ixt,i,k) = zxfluxxt(ixt,i,k) + flux_xt(ixt,i,k,nsrf) * pctsrf(i,nsrf) + ENDDO ! DO ixt=1,niso +#endif + ENDDO + ENDDO + ENDDO + + DO i = 1, klon + zxsens(i) = - zxfluxt(i,1) ! flux de chaleur sensible au sol + zxevap(i) = - zxfluxq(i,1) ! flux d'evaporation au sol + fder_print(i) = fder(i) + dflux_t(i) + dflux_q(i) + ENDDO + + ! if blowing snow + if (ok_bs) then + DO nsrf = 1, nbsrf + DO k = 1, klev + DO i = 1, klon + zxfluxqbs(i,k) = zxfluxqbs(i,k) + flux_qbs(i,k,nsrf) * pctsrf(i,nsrf) + ENDDO + ENDDO + ENDDO + + DO i = 1, klon + zxsnowerosion(i) = zxfluxqbs(i,1) ! blowings snow flux at the surface + END DO + endif + +#ifdef ISO + DO i = 1, klon + DO ixt=1,ntraciso + zxxtevap(ixt,i) = - zxfluxxt(ixt,i,1) + ENDDO + ENDDO +#endif + +!!! + +! +! Incrementer la temperature du sol +! + zxtsol(:) = 0.0 ; zxfluxlat(:) = 0.0 + zt2m(:) = 0.0 ; zq2m(:) = 0.0 ; zn2mout(:,:) = 0 + zustar(:)=0.0 ; zu10m(:) = 0.0 ; zv10m(:) = 0.0 + s_pblh(:) = 0.0 ; s_plcl(:) = 0.0 +!!! jyg le 07/02/2012 + s_pblh_x(:) = 0.0 ; s_plcl_x(:) = 0.0 + s_pblh_w(:) = 0.0 ; s_plcl_w(:) = 0.0 +!!! + s_capCL(:) = 0.0 ; s_oliqCL(:) = 0.0 + s_cteiCL(:) = 0.0; s_pblT(:) = 0.0 + s_therm(:) = 0.0 ; s_trmb1(:) = 0.0 + s_trmb2(:) = 0.0 ; s_trmb3(:) = 0.0 + wstar(:,is_ave)=0. + +! print*,'OK pbl 9' + +!!! nrlmd le 02/05/2011 + zxfluxlat_x(:) = 0.0 ; zxfluxlat_w(:) = 0.0 +!!! + + DO nsrf = 1, nbsrf + DO i = 1, klon + ts(i,nsrf) = ts(i,nsrf) + d_ts(i,nsrf) + + wfbils(i,nsrf) = ( solsw(i,nsrf) + sollw(i,nsrf) & + + flux_t(i,1,nsrf) + fluxlat(i,nsrf) ) * pctsrf(i,nsrf) + + wfevap(i,nsrf) = evap(i,nsrf)*pctsrf(i,nsrf) + + zxtsol(i) = zxtsol(i) + ts(i,nsrf) * pctsrf(i,nsrf) + zxfluxlat(i) = zxfluxlat(i) + fluxlat(i,nsrf) * pctsrf(i,nsrf) + ENDDO + ENDDO +! +!al1 + +!!! jyg le 07/02/2012 + IF (iflag_split .eq.0) THEN + DO nsrf = 1, nbsrf + DO i = 1, klon + zt2m(i) = zt2m(i) + t2m(i,nsrf) * pctsrf(i,nsrf) + zq2m(i) = zq2m(i) + q2m(i,nsrf) * pctsrf(i,nsrf) +! + DO k = 1, 6 + zn2mout(i,k) = zn2mout(i,k) + n2mout(i,nsrf,k) * pctsrf(i,nsrf) + ENDDO +! + zustar(i) = zustar(i) + ustar(i,nsrf) * pctsrf(i,nsrf) + wstar(i,is_ave)=wstar(i,is_ave)+wstar(i,nsrf)*pctsrf(i,nsrf) + zu10m(i) = zu10m(i) + u10m(i,nsrf) * pctsrf(i,nsrf) + zv10m(i) = zv10m(i) + v10m(i,nsrf) * pctsrf(i,nsrf) + + s_pblh(i) = s_pblh(i) + pblh(i,nsrf) * pctsrf(i,nsrf) + s_plcl(i) = s_plcl(i) + plcl(i,nsrf) * pctsrf(i,nsrf) + s_capCL(i) = s_capCL(i) + capCL(i,nsrf) * pctsrf(i,nsrf) + s_oliqCL(i) = s_oliqCL(i) + oliqCL(i,nsrf)* pctsrf(i,nsrf) + s_cteiCL(i) = s_cteiCL(i) + cteiCL(i,nsrf)* pctsrf(i,nsrf) + s_pblT(i) = s_pblT(i) + pblT(i,nsrf) * pctsrf(i,nsrf) + s_therm(i) = s_therm(i) + therm(i,nsrf) * pctsrf(i,nsrf) + s_trmb1(i) = s_trmb1(i) + trmb1(i,nsrf) * pctsrf(i,nsrf) + s_trmb2(i) = s_trmb2(i) + trmb2(i,nsrf) * pctsrf(i,nsrf) + s_trmb3(i) = s_trmb3(i) + trmb3(i,nsrf) * pctsrf(i,nsrf) + ENDDO + ENDDO + ELSE !(iflag_split .eq.0) + DO nsrf = 1, nbsrf + DO i = 1, klon +!!! nrlmd le 02/05/2011 + zxfluxlat_x(i) = zxfluxlat_x(i) + fluxlat_x(i,nsrf) * pctsrf(i,nsrf) + zxfluxlat_w(i) = zxfluxlat_w(i) + fluxlat_w(i,nsrf) * pctsrf(i,nsrf) +!!! +!!! jyg le 08/02/2012 +!! Pour le moment, on sort les valeurs dans (x) et (w) de pblh et de plcl ; +!! pour zt2m, on fait la moyenne surfacique sur les sous-surfaces ; +!! pour qsat2m, on fait la moyenne surfacique sur (x) et (w) ; +!! pour les autres variables, on sort les valeurs de la region (x). + zt2m(i) = zt2m(i) + (t2m_x(i,nsrf)+wake_s(i)*(t2m_w(i,nsrf)-t2m_x(i,nsrf))) * pctsrf(i,nsrf) + zq2m(i) = zq2m(i) + q2m_x(i,nsrf) * pctsrf(i,nsrf) +! + DO k = 1, 6 + zn2mout(i,k) = zn2mout(i,k) + n2mout_x(i,nsrf,k) * pctsrf(i,nsrf) + ENDDO +! + zustar(i) = zustar(i) + ustar_x(i,nsrf) * pctsrf(i,nsrf) + wstar(i,is_ave)=wstar(i,is_ave)+wstar_x(i,nsrf)*pctsrf(i,nsrf) + zu10m(i) = zu10m(i) + u10m_x(i,nsrf) * pctsrf(i,nsrf) + zv10m(i) = zv10m(i) + v10m_x(i,nsrf) * pctsrf(i,nsrf) +! + s_pblh(i) = s_pblh(i) + pblh_x(i,nsrf) * pctsrf(i,nsrf) + s_pblh_x(i) = s_pblh_x(i) + pblh_x(i,nsrf) * pctsrf(i,nsrf) + s_pblh_w(i) = s_pblh_w(i) + pblh_w(i,nsrf) * pctsrf(i,nsrf) +! + s_plcl(i) = s_plcl(i) + plcl_x(i,nsrf) * pctsrf(i,nsrf) + s_plcl_x(i) = s_plcl_x(i) + plcl_x(i,nsrf) * pctsrf(i,nsrf) + s_plcl_w(i) = s_plcl_w(i) + plcl_w(i,nsrf) * pctsrf(i,nsrf) +! + s_capCL(i) = s_capCL(i) + capCL_x(i,nsrf) * pctsrf(i,nsrf) + s_oliqCL(i) = s_oliqCL(i) + oliqCL_x(i,nsrf)* pctsrf(i,nsrf) + s_cteiCL(i) = s_cteiCL(i) + cteiCL_x(i,nsrf)* pctsrf(i,nsrf) + s_pblT(i) = s_pblT(i) + pblT_x(i,nsrf) * pctsrf(i,nsrf) + s_therm(i) = s_therm(i) + therm_x(i,nsrf) * pctsrf(i,nsrf) + s_trmb1(i) = s_trmb1(i) + trmb1_x(i,nsrf) * pctsrf(i,nsrf) + s_trmb2(i) = s_trmb2(i) + trmb2_x(i,nsrf) * pctsrf(i,nsrf) + s_trmb3(i) = s_trmb3(i) + trmb3_x(i,nsrf) * pctsrf(i,nsrf) + ENDDO + ENDDO + DO i = 1, klon + qsat2m(i)= qsat2m_x(i)+ wake_s(i)*(qsat2m_x(i)-qsat2m_w(i)) + ENDDO +!!! + ENDIF ! (iflag_split .eq.0) +!!! + + IF (check) THEN + amn=MIN(ts(1,is_ter),1000.) + amx=MAX(ts(1,is_ter),-1000.) + DO i=2, klon + amn=MIN(ts(i,is_ter),amn) + amx=MAX(ts(i,is_ter),amx) + ENDDO + PRINT*,' debut apres d_ts min max ftsol(ts)',itap,amn,amx + ENDIF + +!jg ? +!!$! +!!$! If a sub-surface does not exsist for a grid point, the mean value for all +!!$! sub-surfaces is distributed. +!!$! +!!$ DO nsrf = 1, nbsrf +!!$ DO i = 1, klon +!!$ IF ((pctsrf_new(i,nsrf) .LT. epsfra) .OR. (t2m(i,nsrf).EQ.0.)) THEN +!!$ ts(i,nsrf) = zxtsol(i) +!!$ t2m(i,nsrf) = zt2m(i) +!!$ q2m(i,nsrf) = zq2m(i) +!!$ u10m(i,nsrf) = zu10m(i) +!!$ v10m(i,nsrf) = zv10m(i) +!!$ +!!$! Les variables qui suivent sont plus utilise, donc peut-etre pas la peine a les mettre ajour +!!$ pblh(i,nsrf) = s_pblh(i) +!!$ plcl(i,nsrf) = s_plcl(i) +!!$ capCL(i,nsrf) = s_capCL(i) +!!$ oliqCL(i,nsrf) = s_oliqCL(i) +!!$ cteiCL(i,nsrf) = s_cteiCL(i) +!!$ pblT(i,nsrf) = s_pblT(i) +!!$ therm(i,nsrf) = s_therm(i) +!!$ trmb1(i,nsrf) = s_trmb1(i) +!!$ trmb2(i,nsrf) = s_trmb2(i) +!!$ trmb3(i,nsrf) = s_trmb3(i) +!!$ ENDIF +!!$ ENDDO +!!$ ENDDO + + + DO i = 1, klon + fder(i) = - 4.0*RSIGMA*zxtsol(i)**3 + ENDDO + + zxqsurf(:) = 0.0 + zxsnow(:) = 0.0 +#ifdef ISO + zxxtsnow(:,:) = 0.0 +#endif + + DO nsrf = 1, nbsrf + DO i = 1, klon + zxqsurf(i) = zxqsurf(i) + MAX(qsurf(i,nsrf),0.0) * pctsrf(i,nsrf) + zxsnow(i) = zxsnow(i) + snow(i,nsrf) * pctsrf(i,nsrf) +#ifdef ISO + DO ixt=1,niso + zxxtsnow(ixt,i) = zxxtsnow(ixt,i) + xtsnow(ixt,i,nsrf) * pctsrf(i,nsrf) + ENDDO ! DO ixt=1,niso +#endif + ENDDO + ENDDO + +! Premier niveau de vent sortie dans physiq.F + zu1(:) = u(:,1) + zv1(:) = v(:,1) + + END SUBROUTINE pbl_surface +! +!**************************************************************************************** +! + SUBROUTINE pbl_surface_final(fder_rst, snow_rst, qsurf_rst, ftsoil_rst & +#ifdef ISO + ,xtsnow_rst,Rland_ice_rst,Rsol_rst & +#endif + ) + + USE indice_sol_mod +#ifdef ISO +#ifdef ISOVERIF + USE isotopes_mod, ONLY: iso_eau,ridicule + USE isotopes_verif_mod, ONLY: errmax,errmaxrel +#endif +#endif + USE dimsoil_mod_h, ONLY: nsoilmx + +! Ouput variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: fder_rst + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: snow_rst + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: qsurf_rst + REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(OUT) :: ftsoil_rst +#ifdef ISO + REAL, DIMENSION(niso,klon, nbsrf), INTENT(OUT) :: xtsnow_rst + REAL, DIMENSION(niso,klon), INTENT(OUT) :: Rland_ice_rst + REAL, DIMENSION(niso,klon), INTENT(OUT) :: Rsol_rst +#endif + + +!**************************************************************************************** +! Return module variables for writing to restart file +! +!**************************************************************************************** + fder_rst(:) = fder(:) + snow_rst(:,:) = snow(:,:) + qsurf_rst(:,:) = qsurf(:,:) + ftsoil_rst(:,:,:) = ftsoil(:,:,:) +#ifdef ISO + xtsnow_rst(:,:,:) = xtsnow(:,:,:) + Rland_ice_rst(:,:) = Rland_ice(:,:) + Rsol_rst(:,:) = Rsol(:,:) +#endif + +!**************************************************************************************** +! Deallocate module variables +! +!**************************************************************************************** +! DEALLOCATE(qsol, fder, snow, qsurf, evap, rugos, agesno, ftsoil) + IF (ALLOCATED(fder)) DEALLOCATE(fder) + IF (ALLOCATED(hice)) DEALLOCATE(hice) + IF (ALLOCATED(tice)) DEALLOCATE(tice) + IF (ALLOCATED(bilg_cumul)) DEALLOCATE(bilg_cumul) + IF (ALLOCATED(snow)) DEALLOCATE(snow) + IF (ALLOCATED(qsurf)) DEALLOCATE(qsurf) + IF (ALLOCATED(ftsoil)) DEALLOCATE(ftsoil) + IF (ALLOCATED(ydTs0)) DEALLOCATE(ydTs0) + IF (ALLOCATED(ydqs0)) DEALLOCATE(ydqs0) +#ifdef ISO + IF (ALLOCATED(xtsnow)) DEALLOCATE(xtsnow) + IF (ALLOCATED(Rland_ice)) DEALLOCATE(Rland_ice) + IF (ALLOCATED(Rsol)) DEALLOCATE(Rsol) + IF (ALLOCATED(Roce)) DEALLOCATE(Roce) +#endif + +!jyg< +!**************************************************************************************** +! Deallocate variables for pbl splitting +! +!**************************************************************************************** + + CALL wx_pbl_final +!>jyg + + END SUBROUTINE pbl_surface_final +! +!**************************************************************************************** +! + +!albedo SB >>> + SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, & + evap, z0m, z0h, agesno, & + tsurf,alb_dir,alb_dif, ustar, u10m, v10m, tke & +#ifdef ISO + ,xtevap & +#endif +& ) + !albedo SB <<< + ! Give default values where new fraction has appread + + USE compbl_mod_h + USE clesphys_mod_h + USE indice_sol_mod + USE phys_state_var_mod, ONLY: delta_sal, ds_ns, dt_ns, delta_sst, dter, & + dser, dt_ds + USE config_ocean_skin_m, ONLY: activate_ocean_skin + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf_new, pctsrf_old + +! InOutput variables +!**************************************************************************************** + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf +!albedo SB >>> + REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT) :: alb_dir, alb_dif + INTEGER :: k +!albedo SB <<< + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: ustar,u10m, v10m + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: evap, agesno + REAL, DIMENSION(klon,nbsrf+1), INTENT(INOUT) :: z0m,z0h + REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(INOUT) :: tke +#ifdef ISO + REAL, DIMENSION(ntraciso,klon,nbsrf), INTENT(INOUT) :: xtevap +#endif + +! Local variables +!**************************************************************************************** + INTEGER :: nsrf, nsrf_comp1, nsrf_comp2, nsrf_comp3, i + CHARACTER(len=80) :: abort_message + CHARACTER(len=20) :: modname = 'pbl_surface_newfrac' + INTEGER, DIMENSION(nbsrf) :: nfois=0, mfois=0, pfois=0 +#ifdef ISO + INTEGER :: ixt +#endif +! +! All at once !! +!**************************************************************************************** + + DO nsrf = 1, nbsrf + ! First decide complement sub-surfaces + SELECT CASE (nsrf) + CASE(is_oce) + nsrf_comp1=is_sic + nsrf_comp2=is_ter + nsrf_comp3=is_lic + CASE(is_sic) + nsrf_comp1=is_oce + nsrf_comp2=is_ter + nsrf_comp3=is_lic + CASE(is_ter) + nsrf_comp1=is_lic + nsrf_comp2=is_oce + nsrf_comp3=is_sic + CASE(is_lic) + nsrf_comp1=is_ter + nsrf_comp2=is_oce + nsrf_comp3=is_sic + END SELECT + + ! Initialize all new fractions + DO i=1, klon + IF (pctsrf_new(i,nsrf) > 0. .AND. pctsrf_old(i,nsrf) == 0.) THEN + + IF (pctsrf_old(i,nsrf_comp1) > 0.) THEN + ! Use the complement sub-surface, keeping the continents unchanged + qsurf(i,nsrf) = qsurf(i,nsrf_comp1) + evap(i,nsrf) = evap(i,nsrf_comp1) + z0m(i,nsrf) = z0m(i,nsrf_comp1) + z0h(i,nsrf) = z0h(i,nsrf_comp1) + tsurf(i,nsrf) = tsurf(i,nsrf_comp1) +!albedo SB >>> + DO k=1,nsw + alb_dir(i,k,nsrf)=alb_dir(i,k,nsrf_comp1) + alb_dif(i,k,nsrf)=alb_dif(i,k,nsrf_comp1) + ENDDO +!albedo SB <<< + ustar(i,nsrf) = ustar(i,nsrf_comp1) + u10m(i,nsrf) = u10m(i,nsrf_comp1) + v10m(i,nsrf) = v10m(i,nsrf_comp1) +#ifdef ISO + DO ixt=1,ntraciso + xtevap(ixt,i,nsrf) = xtevap(ixt,i,nsrf_comp1) + ENDDO +#endif + IF (iflag_pbl > 1) THEN + tke(i,:,nsrf) = tke(i,:,nsrf_comp1) + ENDIF + mfois(nsrf) = mfois(nsrf) + 1 + ! F. Codron sensible default values for ocean and sea ice + IF (nsrf.EQ.is_oce) THEN + tsurf(i,nsrf) = 271.35 + ! (temperature of sea water under sea ice, so that + ! is also the temperature of appearing sea water) + DO k=1,nsw + alb_dir(i,k,nsrf) = 0.06 ! typical Ocean albedo + alb_dif(i,k,nsrf) = 0.06 + ENDDO + if (activate_ocean_skin >= 1) then + if (activate_ocean_skin == 2 & + .and. type_ocean == "couple") then + delta_sal(i) = 0. + delta_sst(i) = 0. + dter(i) = 0. + dser(i) = 0. + dt_ds(i) = 0. + end if + + ds_ns(i) = 0. + dt_ns(i) = 0. + end if + ELSE IF (nsrf.EQ.is_sic) THEN + tsurf(i,nsrf) = 271.35 + ! (Temperature at base of sea ice. Surface + ! temperature could be higher, up to 0 Celsius + ! degrees. We set it to -1.8 Celsius degrees for + ! consistency with the ocean slab model.) + DO k=1,nsw + alb_dir(i,k,nsrf) = 0.3 ! thin ice + alb_dif(i,k,nsrf) = 0.3 + ENDDO + ENDIF + ELSE + ! The continents have changed. The new fraction receives the mean sum of the existent fractions + qsurf(i,nsrf) = qsurf(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + qsurf(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + evap(i,nsrf) = evap(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + evap(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + z0m(i,nsrf) = z0m(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + z0m(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + z0h(i,nsrf) = z0h(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + z0h(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + tsurf(i,nsrf) = tsurf(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + tsurf(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) +!albedo SB >>> + DO k=1,nsw + alb_dir(i,k,nsrf)=alb_dir(i,k,nsrf_comp2)*pctsrf_old(i,nsrf_comp2)+& + alb_dir(i,k,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + alb_dif(i,k,nsrf)=alb_dif(i,k,nsrf_comp2)*pctsrf_old(i,nsrf_comp2)+& + alb_dif(i,k,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + ENDDO +!albedo SB <<< + ustar(i,nsrf) = ustar(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + ustar(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + u10m(i,nsrf) = u10m(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + u10m(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + v10m(i,nsrf) = v10m(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + v10m(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) +#ifdef ISO + DO ixt=1,ntraciso + xtevap(ixt,i,nsrf) = xtevap(ixt,i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) & + + xtevap(ixt,i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + ENDDO +#endif + IF (iflag_pbl > 1) THEN + tke(i,:,nsrf) = tke(i,:,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + tke(i,:,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + ENDIF + + ! Security abort. This option has never been tested. To test, comment the following line. +! abort_message='The fraction of the continents have changed!' +! CALL abort_physic(modname,abort_message,1) + nfois(nsrf) = nfois(nsrf) + 1 + ENDIF + snow(i,nsrf) = 0. + agesno(i,nsrf) = 0. + ftsoil(i,:,nsrf) = tsurf(i,nsrf) +#ifdef ISO + xtsnow(:,i,nsrf) = 0. +#endif + ELSE + pfois(nsrf) = pfois(nsrf)+ 1 + ENDIF + ENDDO + + ENDDO + + END SUBROUTINE pbl_surface_newfrac +! +!**************************************************************************************** +! +END MODULE pbl_surface_mod Index: LMDZ6/trunk/libf/phylmdiso/surf_land_bucket_hetero_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/surf_land_bucket_hetero_mod.F90 (revision 5943) +++ LMDZ6/trunk/libf/phylmdiso/surf_land_bucket_hetero_mod.F90 (revision 5943) @@ -0,0 +1,426 @@ +! +MODULE surf_land_bucket_hetero_mod +! +! 2025/04 A. Maison (adapted from surf_land_bucket_mod) +! Surface land bucket module with heterogeneous continental sub-surfaces +! This module is used when no external land model is choosen and iflag_hetero_surf = 1 or 2. +! + IMPLICIT NONE + +CONTAINS + + SUBROUTINE surf_land_bucket_hetero(itime, jour, knon, knindex, debut, dtime,& + tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, & + spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, pref, plev, & + u1, v1, gustiness, rugoro, swnet, lwnet, & + snow, qsol, agesno, tsoil, & + qsurf, z0m, z0h, alb1_new, alb2_new, evap, & + fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l, & + tsurf_tersrf, tsoil_tersrf, qsurf_tersrf, tsurf_new_tersrf, & + cdragm_tersrf, cdragh_tersrf, & + swnet_tersrf, lwnet_tersrf, fluxsens_tersrf, fluxlat_tersrf) + + USE clesphys_mod_h + USE dimsoil_mod_h, ONLY: nsoilmx + USE yomcst_mod_h, ONLY: RD, RG, RCPD, RSIGMA + USE compbl_mod_h + USE dimpft_mod_h + USE limit_read_mod + USE surface_data + USE fonte_neige_mod + USE calcul_fluxs_mod + USE cpl_mod + USE dimphy + USE geometry_mod, ONLY: longitude,latitude + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE indice_sol_mod + USE phys_state_var_mod, ONLY: frac_tersrf, ratio_z0m_z0h_tersrf, z0m_tersrf, & + albedo_tersrf, beta_tersrf, inertie_tersrf, & + hcond_tersrf + USE surf_param_mod, ONLY: eff_surf_param, average_surf_var + USE cdrag_mod + +#ifdef ISO + use infotrac_phy, ONLY: niso +#endif + +!**************************************************************************************** +! Bucket calculations for surface. +!**************************************************************************************** +! +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: debut + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: tq_cdrag + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef + REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef + REAL, DIMENSION(klon), INTENT(IN) :: pref + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, gustiness + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon), INTENT(IN) :: swnet, lwnet + REAL, DIMENSION(klon, nbtersrf), INTENT(IN) :: tsurf_tersrf + + +! In/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil + REAL, DIMENSION(klon), INTENT(INOUT) :: plev + REAL, DIMENSION(klon, nsoilmx, nbtersrf), INTENT(INOUT) :: tsoil_tersrf + + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: z0m, z0h + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + ! + REAL, DIMENSION(klon, nbtersrf), INTENT(OUT) :: tsurf_new_tersrf + REAL, DIMENSION(klon, nbtersrf), INTENT(OUT) :: qsurf_tersrf + REAL, DIMENSION(klon, nbtersrf), INTENT(OUT) :: cdragm_tersrf, cdragh_tersrf + REAL, DIMENSION(klon, nbtersrf), INTENT(OUT) :: swnet_tersrf, lwnet_tersrf + REAL, DIMENSION(klon, nbtersrf), INTENT(OUT) :: fluxsens_tersrf, fluxlat_tersrf + +#ifdef ISO +! REAL, DIMENSION(ntiso,klon), INTENT(OUT) :: xtevap +! REAL, DIMENSION(klon), INTENT(OUT) :: h1 +! REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtrunoff_diag + REAL, DIMENSION(klon) :: runoff_diag +! REAL, DIMENSION(niso,klon), INTENT(IN) :: Rland_ice +#endif +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: soilcap, soilflux + REAL, DIMENSION(klon) :: cal, beta, dif_grnd, capsol + REAL, DIMENSION(klon) :: alb_neig, alb_lim, icesub + REAL, DIMENSION(klon) :: zfra + REAL, DIMENSION(klon) :: radsol + REAL, DIMENSION(klon) :: u0, v0, u1_lay, v1_lay + REAL, DIMENSION(klon) :: dummy_riverflow,dummy_coastalflow + INTEGER :: i, j, k +#ifdef ISO + INTEGER :: ixt + REAL, PARAMETER :: t_coup = 273.15 + REAL, DIMENSION(klon) :: fq_fonte_diag + REAL, DIMENSION(klon) :: fqfonte_diag + REAL, DIMENSION(klon) :: snow_evap_diag + REAL, DIMENSION(klon) :: fqcalving_diag + REAL :: max_eau_sol_diag + REAL, DIMENSION(klon) :: run_off_lic_diag + REAL :: coeff_rel_diag +#endif + ! + REAL, DIMENSION(klon) :: zlev, geop1, speed, pblh, ri_in, sst + REAL, DIMENSION(klon) :: beta_eff, inertie_eff, conv_ratio_eff + REAL, DIMENSION(klon) :: meansqT + REAL, DIMENSION(klon, nbtersrf) :: z0h_tersrf, emis_tersrf, conv_ratio_tersrf + REAL, DIMENSION(klon, nbtersrf) :: evap_tersrf + REAL, DIMENSION(klon, nbtersrf) :: dflux_s_tersrf, dflux_l_tersrf + REAL, DIMENSION(klon, nbtersrf) :: radsol_tersrf + REAL, DIMENSION(klon, nbtersrf) :: zri_tersrf + REAL, PARAMETER :: klon_1D = 1 + +! +!**************************************************************************************** + + ! *** Calculations common to the two flag values *** + + ! average albedo + alb_lim = eff_surf_param(klon, nbtersrf, albedo_tersrf, frac_tersrf, 'ARI') + + ! suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + speed(:) = (u1_lay(:)**2 + v1_lay(:)**2)**0.5 + ! + geop1(1:knon) = RD * temp_air(1:knon) / (0.5*(pref(1:knon)+p1lay(1:knon))) & + * (pref(1:knon)-p1lay(1:knon)) + zlev(1:knon) = (plev(1:knon)*RD*temp_air(1:knon)/(pref(1:knon)*RG))/2. + ! + ! compute roughness lengths + DO i=1, knon + DO j=1, nbtersrf + IF (ratio_z0m_z0h_tersrf(i,j) .NE. 0.) THEN + z0h_tersrf(i,j) = z0m_tersrf(i,j) / ratio_z0m_z0h_tersrf(i,j) + ELSE + z0h_tersrf(i,j) = 1.E-12 + ENDIF + ENDDO + ENDDO + + z0m = eff_surf_param(klon, nbtersrf, z0m_tersrf, frac_tersrf, 'CDN', zlev) + z0h = eff_surf_param(klon, nbtersrf, z0h_tersrf, frac_tersrf, 'CDN', zlev) + + DO i=1, knon + z0m(i) = MAX(1.5e-05,SQRT(z0m(i)**2 + rugoro(i)**2)) + END DO + + ! compute the ratio to convert and print soil depths in meters (conv_ratio = (cond/cap)^0.5 and cap = I^2/cond) + DO j=1, nbtersrf + conv_ratio_tersrf(:,j) = hcond_tersrf(:,j)/inertie_tersrf(:,j) + ENDDO + + ! + ! *** Surface parameter aggregation *** + ! + IF (iflag_hetero_surf == 1) THEN + !* Calcultaion of fluxes + + ! calculate total absorbed radiance at surface + radsol(:) = 0.0 + radsol(1:knon) = swnet(1:knon) + lwnet(1:knon) + + ! calculate constants (needeed for capsol and dif_grnd) + CALL calbeta(dtime, is_ter, knon, snow, qsol, beta, capsol, dif_grnd) + IF (type_veget=='betaclim') THEN + CALL calbeta_clim(knon,jour,latitude(knindex(1:knon)),beta) + ENDIF + + ! mean evapotranspiration coefficient + beta_eff = eff_surf_param(klon, nbtersrf, beta_tersrf, frac_tersrf, 'ARI') + beta = beta_eff + + ! calculate temperature, heat capacity and conduction flux in soil + IF (soil_model) THEN + inertie_eff = eff_surf_param(klon, nbtersrf, inertie_tersrf, frac_tersrf, 'ARI') + conv_ratio_eff = eff_surf_param(klon, nbtersrf, conv_ratio_tersrf, frac_tersrf, 'ARI') + ! + CALL soil_hetero(dtime, is_ter, knon, snow, tsurf, qsol, & + & longitude(knindex(1:knon)), latitude(knindex(1:knon)), tsoil, soilcap, soilflux, & + & inertie_eff, conv_ratio_eff) + ! + DO i=1, knon + cal(i) = RCPD / soilcap(i) + radsol(i) = radsol(i) + soilflux(i) + END DO + ELSE + cal(:) = RCPD * capsol(:) + IF (klon_glo .EQ. 1) THEN + cal(:) = 0. + ENDIF + ENDIF + + ! calculate fluxes + CALL calcul_fluxs(knon, is_ter, dtime, & + tsurf, p1lay, cal, beta, tq_cdrag, tq_cdrag, pref, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, & + 1.,petAcoef, peqAcoef, petBcoef, peqBcoef, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + + + !* Calculate snow height, run_off, age of snow +#ifdef ISO + DO i=1,knon + ! initialisation: + fqfonte_diag(i) =0.0 + fq_fonte_diag(i) =0.0 + snow_evap_diag(i)=0.0 + ENDDO !DO i=1,knon +#endif + + CALL fonte_neige( knon, is_ter, knindex, dtime, & + tsurf, precip_rain, precip_snow, & + snow, qsol, tsurf_new, evap, icesub & +#ifdef ISO + & ,fq_fonte_diag,fqfonte_diag,snow_evap_diag,fqcalving_diag & + & ,max_eau_sol_diag,runoff_diag,run_off_lic_diag,coeff_rel_diag & +#endif + & ) + + ! calculate the age of snow + CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:)) + + WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0. + + DO i=1, knon + zfra(i) = MAX(0.0,MIN(1.0, snow(i)/(snow(i)+10.0))) + alb_lim(i) = alb_neig(i) *zfra(i) + alb_lim(i)*(1.0-zfra(i)) + END DO + + + !* Return albedo : + ! alb1_new and alb2_new are here given the same values + + alb1_new(:) = 0.0 + alb2_new(:) = 0.0 + alb1_new(1:knon) = alb_lim(1:knon) + alb2_new(1:knon) = alb_lim(1:knon) + + !* Send to coupler + ! The run-off from river and coast are not calculated in the bucket modele. + ! For testing purpose of the coupled modele we put the run-off to zero. + IF (type_ocean=='couple') THEN + dummy_riverflow(:) = 0.0 + dummy_coastalflow(:) = 0.0 + CALL cpl_send_land_fields(itime, knon, knindex, & + dummy_riverflow, dummy_coastalflow) + ENDIF + + ! + ! *** Flux aggregation *** + ! + ELSE IF (iflag_hetero_surf == 2) THEN + ! initialize output tables + evap_tersrf(:,:) = 0. + fluxsens_tersrf(:,:) = 0. + fluxlat_tersrf(:,:) = 0. + tsurf_new_tersrf(:,:) = 0. + dflux_s_tersrf(:,:) = 0. + dflux_l_tersrf(:,:) = 0. + radsol_tersrf(:,:) = 0. + swnet_tersrf(:,:) = 0. + lwnet_tersrf(:,:) = 0. + ! hyp: surface emissivity = 1 + emis_tersrf(:,:) = 1. + + ! * calculate total absorbed radiance at surface + DO j=1, nbtersrf + ! SW + swnet_tersrf(klon_1D,j) = (1. - albedo_tersrf(klon_1D,j)) / (1. - alb_lim(klon_1D)) * swnet(klon_1D) + ! LW + ! first order + lwnet_tersrf(klon_1D,j) = lwnet(klon_1D) + 4. * emis_tersrf(klon_1D,j) * RSIGMA * tsurf(klon_1D)**3 * & + (tsurf(klon_1D) - tsurf_tersrf(klon_1D,j)) + ENDDO + ! LW second order corrections + !- net = dwn -up; up=sig( T4 + 4sum%T3T' + 6sum%T2T'2 +...) + IF (iflag_order2_sollw == 1) THEN + meansqT(:) = 0. ! as working buffer + ! + DO j=1, nbtersrf + meansqT(klon_1D) = meansqT(klon_1D) + (tsurf_tersrf(klon_1D,j) - tsurf(klon_1D))**2 * frac_tersrf(klon_1D,j) + ENDDO + DO j=1, nbtersrf + lwnet_tersrf(klon_1D,j) = lwnet_tersrf(klon_1D,j) + 6. * RSIGMA * tsurf(klon_1D)**2 * (meansqT(klon_1D) - & + (tsurf(klon_1D) - tsurf_tersrf(klon_1D,j))**2) + ENDDO + ENDIF + ! net radiation + radsol_tersrf(:,:) = swnet_tersrf(:,:) + lwnet_tersrf(:,:) + + ! * compute evapotranspiration coefficient + capsol(:) = 1.0/(2.5578E+06*0.15) + dif_grnd(:) = 0. + + ! unused variables in cdrag routine + pblh(:) = 0. + ri_in(:) = 0. + sst(:) = 0. + + ! Loop on sub-surfaces + DO j=1, nbtersrf + ! * drag coefficients + CALL cdrag(knon, is_ter, speed, temp_air, spechum, geop1, pref, pblh, & + tsurf_tersrf(:,j), qsurf_tersrf(:,j), z0m_tersrf(:,j), z0h_tersrf(:,j), ri_in, 0, & + cdragm_tersrf(:,j), cdragh_tersrf(:,j), zri_tersrf(:,j), plev, precip_rain, sst, p1lay) + + ! * calculate temperature, heat capacity and conduction flux in soil + IF (soil_model) THEN + ! + CALL soil_hetero(dtime, is_ter, knon, snow, tsurf_tersrf(:,j), qsol, & + longitude(knindex(1:knon)), latitude(knindex(1:knon)), tsoil_tersrf(:,:,j), soilcap, soilflux, & + inertie_tersrf(:,j), conv_ratio_tersrf(:,j)) + ! + cal(:) = RCPD / soilcap(:) + radsol_tersrf(:,j) = radsol_tersrf(:,j) + soilflux(:) + ! + ELSE + cal = RCPD * capsol + IF (klon_glo .EQ. 1) THEN + cal = 0. + ENDIF + ENDIF + + ! * calcultaion of fluxes + CALL calcul_fluxs(knon, is_ter, dtime, & + tsurf_tersrf(klon_1D,j), p1lay, cal, beta_tersrf(klon_1D,j), cdragh_tersrf(klon_1D,j), cdragh_tersrf(klon_1D,j), pref, & + precip_rain, precip_snow, snow, qsurf_tersrf(klon_1D,j), & + radsol_tersrf(klon_1D,j), dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, & + 1.,petAcoef, peqAcoef, petBcoef, peqBcoef, & + tsurf_new_tersrf(klon_1D,j), evap_tersrf(klon_1D,j), fluxlat_tersrf(klon_1D,j), fluxsens_tersrf(klon_1D,j), & + dflux_s_tersrf(klon_1D,j), dflux_l_tersrf(klon_1D,j)) + + ! if snow > 0 + ! calculate snow height, run_off, age of snow + CALL fonte_neige( knon, is_ter, knindex, dtime, & + tsurf_tersrf(:,j), precip_rain, precip_snow, & + snow, qsol, tsurf_new_tersrf(:,j), evap_tersrf(:,j), icesub & +#ifdef ISO + & ,fq_fonte_diag,fqfonte_diag,snow_evap_diag,fqcalving_diag & + & ,max_eau_sol_diag,runoff_diag,run_off_lic_diag,coeff_rel_diag & +#endif + & ) + + ENDDO ! loop on sub-surfaces + + ! calculate the age of snow + CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:)) + WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0. + + DO i=1, knon + zfra(i) = MAX(0.0,MIN(1.0, snow(i)/(snow(i)+10.0))) + alb_lim(i) = alb_neig(i) *zfra(i) + alb_lim(i)*(1.0-zfra(i)) + END DO + + ! return albedo : + ! alb1_new and alb2_new are here given the same values + alb1_new(:) = 0.0 + alb2_new(:) = 0.0 + alb1_new(1:knon) = alb_lim(1:knon) + alb2_new(1:knon) = alb_lim(1:knon) + + ! send to coupler + ! the run-off from river and coast are not calculated in the bucket modele. + ! for testing purpose of the coupled modele we put the run-off to zero. + IF (type_ocean=='couple') THEN + dummy_riverflow(:) = 0.0 + dummy_coastalflow(:) = 0.0 + CALL cpl_send_land_fields(itime, knon, knindex, & + dummy_riverflow, dummy_coastalflow) + ENDIF + + ! * average of fluxes and surface variables + qsurf = average_surf_var(klon, nbtersrf, qsurf_tersrf, frac_tersrf, 'ARI') + tsurf_new = average_surf_var(klon, nbtersrf, tsurf_new_tersrf, frac_tersrf, 'ARI') + evap = average_surf_var(klon, nbtersrf, evap_tersrf, frac_tersrf, 'ARI') + fluxlat = average_surf_var(klon, nbtersrf, fluxlat_tersrf, frac_tersrf, 'ARI') + fluxsens = average_surf_var(klon, nbtersrf, fluxsens_tersrf, frac_tersrf, 'ARI') + dflux_l = average_surf_var(klon, nbtersrf, dflux_l_tersrf, frac_tersrf, 'ARI') + dflux_s = average_surf_var(klon, nbtersrf, dflux_s_tersrf, frac_tersrf, 'ARI') + DO k=1, nsoilmx + tsoil(:,k) = average_surf_var(klon, nbtersrf, tsoil_tersrf(:,k,:), frac_tersrf, 'ARI') + ENDDO + + ! order 2 correction to tsurf_new, for radiation computations (main atm effect of Ts) + IF (iflag_order2_sollw == 1) THEN + meansqT(:) = 0. ! as working buffer + DO j=1, nbtersrf + meansqT(klon_1D) = meansqT(klon_1D)+(tsurf_tersrf(klon_1D,j)-tsurf_new(klon_1D))**2 *frac_tersrf(klon_1D,j) + ENDDO + tsurf_new(:) = tsurf_new(:)+1.5*meansqT(:)/tsurf_new(:) + ENDIF ! iflag_order2_sollw == 1 + + ENDIF ! iflag_hetero_surf +! +!* End +! + END SUBROUTINE surf_land_bucket_hetero +! +!**************************************************************************************** +! +END MODULE surf_land_bucket_hetero_mod Index: LMDZ6/trunk/libf/phylmdiso/surf_land_bucket_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/surf_land_bucket_mod.F90 (revision 5943) +++ LMDZ6/trunk/libf/phylmdiso/surf_land_bucket_mod.F90 (revision 5943) @@ -0,0 +1,346 @@ +! +MODULE surf_land_bucket_mod +! +! Surface land bucket module +! +! This module is used when no external land model is choosen. +! + IMPLICIT NONE + +CONTAINS + + SUBROUTINE surf_land_bucket(itime, jour, knon, knindex, debut, dtime,& + tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, & + spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, pref, & + u1, v1, gustiness, rugoro, swnet, lwnet, & + snow, qsol, agesno, tsoil, & + qsurf, z0_new, alb1_new, alb2_new, evap, & + fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l & +#ifdef ISO + ,xtprecip_rain, xtprecip_snow,xtspechum, & + xtsnow, xtsol,xtevap,h1, & + runoff_diag,xtrunoff_diag,Rland_ice & +#endif + ) + + USE limit_read_mod + USE surface_data + USE fonte_neige_mod + USE calcul_fluxs_mod + USE cpl_mod + USE dimphy + USE geometry_mod, ONLY: longitude,latitude + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE indice_sol_mod +#ifdef ISO + use infotrac_phy, ONLY: ntiso,niso + USE isotopes_mod, ONLY: iso_eau, iso_HDO, iso_O18, iso_O17, & + ridicule_qsol + USE isotopes_routines_mod, ONLY: calcul_iso_surf_ter_vectall +#ifdef ISOVERIF + USE isotopes_verif_mod, ONLY: errmax,errmaxrel,iso_verif_noNaN, & + iso_verif_aberrant_o17,iso_verif_egalite_choix,iso_verif_egalite +#endif +#endif + USE clesphys_mod_h + USE yomcst_mod_h + USE dimsoil_mod_h, ONLY: nsoilmx +!**************************************************************************************** +! Bucket calculations for surface. +! + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: debut + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: tq_cdrag + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef + REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef + REAL, DIMENSION(klon), INTENT(IN) :: pref + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, gustiness + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon), INTENT(IN) :: swnet, lwnet +#ifdef ISO + REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtprecip_rain, xtprecip_snow + REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtspechum +#endif + +! In/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil +#ifdef ISO + REAL, DIMENSION(niso,klon), INTENT(INOUT) :: xtsnow,xtsol +#endif + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: z0_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l +#ifdef ISO + REAL, DIMENSION(ntiso,klon), INTENT(OUT) :: xtevap + REAL, DIMENSION(klon), INTENT(OUT) :: h1 + REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtrunoff_diag + REAL, DIMENSION(klon), INTENT(OUT) :: runoff_diag + REAL, DIMENSION(niso,klon), INTENT(IN) :: Rland_ice +#endif + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: soilcap, soilflux + REAL, DIMENSION(klon) :: cal, beta, dif_grnd, capsol + REAL, DIMENSION(klon) :: alb_neig, alb_lim, icesub + REAL, DIMENSION(klon) :: zfra + REAL, DIMENSION(klon) :: radsol ! total net radiance at surface + REAL, DIMENSION(klon) :: u0, v0, u1_lay, v1_lay + REAL, DIMENSION(klon) :: dummy_riverflow,dummy_coastalflow + INTEGER :: i +#ifdef ISO + INTEGER :: ixt + REAL, DIMENSION(niso,klon) :: xtsnow_prec,xtsol_prec + REAL, DIMENSION(klon) :: snow_prec,qsol_prec + REAL, PARAMETER :: t_coup = 273.15 + REAL, DIMENSION(klon) :: fq_fonte_diag + REAL, DIMENSION(klon) :: fqfonte_diag + REAL, DIMENSION(klon) :: snow_evap_diag + REAL, DIMENSION(klon) :: fqcalving_diag + REAL :: max_eau_sol_diag + REAL, DIMENSION(klon) :: run_off_lic_diag + REAL :: coeff_rel_diag +#endif +! +!**************************************************************************************** + +#ifdef ISO +#ifdef ISOVERIF + !write(*,*) 'surf_land_bucket 152' + DO i=1,knon + IF (iso_eau > 0) THEN + CALL iso_verif_egalite_choix(precip_snow(i), & + & xtprecip_snow(iso_eau,i),'surf_land_bucket 131', & + & errmax,errmaxrel) + CALL iso_verif_egalite_choix(qsol(i), & + & xtsol(iso_eau,i),'surf_land_bucket 134', & + & errmax,errmaxrel) + ENDIF + ENDDO +#endif +#ifdef ISOVERIF + DO i=1,knon + DO ixt=1,niso + CALL iso_verif_noNaN(xtsol(ixt,i),'surf_land_mod_bucket 142') + ENDDO !do ixt=1,niso + ENDDO !do i=1,knon + !write(*,*) 'surf_land_bucket 152' +#endif +#endif + +! +!* Read from limit.nc : albedo(alb_lim), length of rugosity(z0_new) +! + CALL limit_read_rug_alb(itime, dtime, jour,& + knon, knindex, & + z0_new, alb_lim) +! +!* Calcultaion of fluxes +! + +! calculate total absorbed radiance at surface + radsol(:) = 0.0 + radsol(1:knon) = swnet(1:knon) + lwnet(1:knon) + +! calculate constants + CALL calbeta(dtime, is_ter, knon, snow, qsol, beta, capsol, dif_grnd) + if (type_veget=='betaclim') then + CALL calbeta_clim(knon,jour,latitude(knindex(1:knon)),beta) + endif + +! calculate temperature, heat capacity and conduction flux in soil + IF (soil_model) THEN + CALL soil(dtime, is_ter, knon, snow, tsurf, qsol, & + & longitude(knindex(1:knon)), latitude(knindex(1:knon)), tsoil, soilcap, soilflux) + + DO i=1, knon + cal(i) = RCPD / soilcap(i) + radsol(i) = radsol(i) + soilflux(i) + END DO + ELSE + cal(:) = RCPD * capsol(:) + IF (klon_glo .EQ. 1) THEN + cal(:) = 0. + ENDIF + ENDIF + +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + + CALL calcul_fluxs(knon, is_ter, dtime, & + tsurf, p1lay, cal, beta, tq_cdrag, tq_cdrag, pref, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, & + 1.,petAcoef, peqAcoef, petBcoef, peqBcoef, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + +#ifdef ISO + ! verif +#ifdef ISOVERIF + !write(*,*) 'surf_land_bucket 211' + DO i=1,knon + IF (iso_eau > 0) THEN + CALL iso_verif_egalite_choix(xtsnow(iso_eau,i), & + & snow(i),'surf_land_bucket 522', & + & errmax,errmaxrel) + ENDIF !IF (iso_eau > 0) then + ENDDO !DO i=1,knon +#endif + ! end verif +#endif +#ifdef ISO + DO i=1,knon + snow_prec(i)=snow(i) + qsol_prec(i)=qsol(i) + DO ixt=1,niso + xtsnow_prec(ixt,i)=xtsnow(ixt,i) + xtsol_prec(ixt,i) =xtsol(ixt,i) + ENDDO !DO ixt=1,niso + ! initialisation: + fqfonte_diag(i) =0.0 + fq_fonte_diag(i) =0.0 + snow_evap_diag(i)=0.0 + ENDDO !DO i=1,knon +#ifdef ISOVERIF + ! write(*,*) 'surf_land_bucket 235' + DO i=1,knon + IF (iso_eau > 0) THEN + CALL iso_verif_egalite(qsol_prec(i),xtsol_prec(iso_eau,i), & + & 'surf_land_bucket 141') + ENDIF + ENDDO !DO i=1,knon +#endif +#endif +! +!* Calculate snow height, run_off, age of snow +! + CALL fonte_neige( knon, is_ter, knindex, dtime, & + tsurf, precip_rain, precip_snow, & + snow, qsol, tsurf_new, evap, icesub & +#ifdef ISO + & ,fq_fonte_diag,fqfonte_diag,snow_evap_diag,fqcalving_diag & + & ,max_eau_sol_diag,runoff_diag,run_off_lic_diag,coeff_rel_diag & +#endif + & ) + +#ifdef ISO +#ifdef ISOVERIF + DO i=1,knon + DO ixt=1,niso + CALL iso_verif_noNaN(xtsol_prec(ixt,i),'surf_land_burcket 237') + ENDDO + ENDDO +#endif +#ifdef ISOVERIF + !write(*,*) 'surf_land_bucket 235' + DO i=1,knon + IF (iso_eau > 0) THEN + CALL iso_verif_egalite_choix(qsol_prec(i), & + & xtsol_prec(iso_eau,i),'surf_land_bucket 628', & + & errmax,errmaxrel) + CALL iso_verif_egalite_choix(precip_snow(i), & + & xtprecip_snow(iso_eau,i),'surf_land_bucket 227', & + & errmax,errmaxrel) + ! attention, dans fonte_neige, on modifie snow sans modifier + ! xtsnow + ! c'est fait plus tard dans gestion_neige +! write(*,*) 'surf_land_bucket 287: i=',i +! write(*,*) 'snow(i)=',snow(i) + CALL iso_verif_egalite_choix(xtsnow(iso_eau,i), & + & snow_prec(i),'surf_land_bucket 245', & + & errmax,errmaxrel) + ENDIF + IF ((iso_O17 > 0).AND.(iso_O18 > 0)) THEN + IF (qsol_prec(i) > ridicule_qsol) THEN + CALL iso_verif_aberrant_o17(xtsol_prec(iso_O17,i)/qsol_prec(i) & + & ,xtsol_prec(iso_O18,i)/qsol_prec(i) & + & ,'surf_land_bucket 642') + ENDIF !IF ((qsol_prec(i) > ridicule_qsol) & + ENDIF !IF ((iso_O17 > 0).AND.(iso_O18 > 0)) THEN + ENDDO !DO i=1,knon + !write(*,*) 'surf_land_mod 291' + !write(*,*) 'snow_evap_diag(1)=',snow_evap_diag(1) +#endif + CALL calcul_iso_surf_ter_vectall(klon,knon, & + & evap,snow_evap_diag,snow, & + & fq_fonte_diag,fqfonte_diag,dtime,precip_rain,xtprecip_rain, & + & precip_snow,xtprecip_snow, snow_prec,xtsnow_prec, & + & tsurf_new,xtspechum,pref,spechum,t_coup,u1_lay,v1_lay,p1lay, & + & qsol,xtsol,qsol_prec,xtsol_prec, & + & max_eau_sol_diag, & + & xtevap,xtsnow,h1,runoff_diag,xtrunoff_diag,fqcalving_diag, & + & knindex,is_ter,run_off_lic_diag,coeff_rel_diag,Rland_ice & + & ) +!#ifdef ISOVERIF +! write(*,*) 'surf_land_bucket 303' +!#endif +#endif + +! +!* Calculate the age of snow +! + CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:)) + + WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0. + + DO i=1, knon + zfra(i) = MAX(0.0,MIN(1.0, snow(i)/(snow(i)+10.0))) + alb_lim(i) = alb_neig(i) *zfra(i) + alb_lim(i)*(1.0-zfra(i)) + END DO + +! +!* Return albedo : +! alb1_new and alb2_new are here given the same values +! + alb1_new(:) = 0.0 + alb2_new(:) = 0.0 + alb1_new(1:knon) = alb_lim(1:knon) + alb2_new(1:knon) = alb_lim(1:knon) + +! +!* Calculate the rugosity +! + DO i = 1, knon + z0_new(i) = MAX(1.5e-05,SQRT(z0_new(i)**2 + rugoro(i)**2)) + END DO + +!* Send to coupler +! The run-off from river and coast are not calculated in the bucket modele. +! For testing purpose of the coupled modele we put the run-off to zero. + IF (type_ocean=='couple') THEN + dummy_riverflow(:) = 0.0 + dummy_coastalflow(:) = 0.0 + CALL cpl_send_land_fields(itime, knon, knindex, & + dummy_riverflow, dummy_coastalflow) + ENDIF + +! +!* End +! + END SUBROUTINE surf_land_bucket +! +!**************************************************************************************** +! +END MODULE surf_land_bucket_mod Index: LMDZ6/trunk/libf/phylmdiso/surf_land_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/surf_land_mod.F90 (revision 5943) +++ LMDZ6/trunk/libf/phylmdiso/surf_land_mod.F90 (revision 5943) @@ -0,0 +1,481 @@ +! +MODULE surf_land_mod + + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_land(itime, dtime, date0, jour, knon, knindex, & + rlon, rlat, yrmu0, & + debut, lafin, zlev, ccanopy, swnet, lwnet, albedo, & + tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, precip_bs, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + pref, u1, v1, gustiness, rugoro, pctsrf, & + lwdown_m, q2m, t2m, & + snow, qsol, agesno, tsoil, & + z0m, z0h, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, fluxbs, & + qsurf, tsurf_new, dflux_s, dflux_l, & + flux_u1, flux_v1 , & + veget,lai,height, tsurf_tersrf, tsoil_tersrf, qsurf_tersrf, tsurf_new_tersrf, & + cdragm_tersrf, cdragh_tersrf, & + swnet_tersrf, lwnet_tersrf, fluxsens_tersrf, fluxlat_tersrf & +#ifdef ISO + ,xtprecip_rain, xtprecip_snow,xtspechum, & + xtsnow, xtsol,xtevap,h1, & + runoff_diag,xtrunoff_diag,Rland_ice, & + xtriverflow, xtcoastalflow, Rsol & +#endif + ) + + USE dimphy + USE surface_data, ONLY : ok_veget + USE carbon_cycle_mod + + + ! See comments in each module surf_land_orchidee_xxx for compatiblity with ORCHIDEE +#ifdef ORCHIDEE_NOOPENMP + ! Compilation with cpp key ORCHIDEE NOOPENMP + USE surf_land_orchidee_noopenmp_mod +#else +#if ORCHIDEE_NOZ0H + ! Compilation with cpp key ORCHIDEE NOZ0H + USE surf_land_orchidee_noz0h_mod +#else +#if ORCHIDEE_NOFREIN + ! Compilation with cpp key ORCHIDEE_NOFREIN + USE surf_land_orchidee_nofrein_mod +#else +#if ORCHIDEE_NOUNSTRUCT + ! Compilation with cpp key ORCHIDEE_NOUNSTRUCT + USE surf_land_orchidee_nounstruct_mod +#else +#if ORCHIDEE_NOLIC + ! Compilation with cpp key ORCHIDEE_NOLIC + USE surf_land_orchidee_nolic_mod +#else + ! Default version + USE surf_land_orchidee_mod +#endif +#endif +#endif +#endif +#endif + + USE surf_land_bucket_mod + USE surf_land_bucket_hetero_mod + USE calcul_fluxs_mod + USE indice_sol_mod +#ifdef ISO + use infotrac_phy, ONLY: ntiso,niso + use isotopes_mod, ONLY: nudge_qsol, iso_eau +#ifdef ISOVERIF + use isotopes_verif_mod +#endif +#endif + +USE dimpft_mod_h + USE clesphys_mod_h + USE yomcst_mod_h +USE print_control_mod, ONLY: lunout + USE dimsoil_mod_h, ONLY: nsoilmx + USE compbl_mod_h + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: date0 + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: yrmu0 ! cosine of solar zenith angle + LOGICAL, INTENT(IN) :: debut, lafin + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: ccanopy + REAL, DIMENSION(klon), INTENT(IN) :: swnet, lwnet + REAL, DIMENSION(klon), INTENT(IN) :: albedo ! albedo for whole short-wave interval + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow, precip_bs + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: pref ! pressure reference + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, gustiness + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + REAL, DIMENSION(klon), INTENT(IN) :: lwdown_m ! downwelling longwave radiation at mean surface + ! corresponds to previous sollwdown + REAL, DIMENSION(klon), INTENT(IN) :: q2m, t2m + REAL, DIMENSION(klon, nbtersrf), INTENT(IN) :: tsurf_tersrf +#ifdef ISO + REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtprecip_rain, xtprecip_snow + REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtspechum +#endif +! In/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil + REAL, DIMENSION(klon), INTENT(INOUT) :: zlev + REAL, DIMENSION(klon, nsoilmx, nbtersrf), INTENT(INOUT) :: tsoil_tersrf +#ifdef ISO + REAL, DIMENSION(niso,klon), INTENT(INOUT) :: xtsnow, xtsol + REAL, DIMENSION(niso,klon), INTENT(INOUT) :: Rsol +#endif + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: z0m, z0h +!albedo SB >>> +! REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new ! albdeo for shortwave interval 1(visible) +! REAL, DIMENSION(klon), INTENT(OUT) :: alb2_new ! albedo for shortwave interval 2(near infrared) + REAL, DIMENSION(6), INTENT(IN) :: SFRWL + REAL, DIMENSION(klon,nsw), INTENT(OUT) :: alb_dir_new,alb_dif_new +!albedo SB <<< + REAL, DIMENSION(klon), INTENT(OUT) :: evap + REAL, DIMENSION(klon), INTENT(OUT) :: fluxsens, fluxlat, fluxbs + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 ! flux for U and V at first model level + REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: veget,lai + REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: height +! AM + REAL, DIMENSION(klon, nbtersrf), INTENT(OUT) :: tsurf_new_tersrf + REAL, DIMENSION(klon, nbtersrf), INTENT(OUT) :: qsurf_tersrf + REAL, DIMENSION(klon, nbtersrf), INTENT(OUT) :: cdragm_tersrf + REAL, DIMENSION(klon, nbtersrf), INTENT(OUT) :: cdragh_tersrf + REAL, DIMENSION(klon, nbtersrf), INTENT(OUT) :: swnet_tersrf + REAL, DIMENSION(klon, nbtersrf), INTENT(OUT) :: lwnet_tersrf + REAL, DIMENSION(klon, nbtersrf), INTENT(OUT) :: fluxsens_tersrf + REAL, DIMENSION(klon, nbtersrf), INTENT(OUT) :: fluxlat_tersrf +#ifdef ISO + REAL, DIMENSION(ntiso,klon), INTENT(OUT) :: xtevap + REAL, DIMENSION(klon), INTENT(OUT) :: h1 + REAL, DIMENSION(klon), INTENT(OUT) :: runoff_diag + REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtrunoff_diag + REAL, DIMENSION(niso,klon), INTENT(IN) :: Rland_ice + REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtriverflow + REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtcoastalflow +#endif + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: p1lay_tmp + REAL, DIMENSION(klon) :: pref_tmp + REAL, DIMENSION(klon) :: swdown ! downwelling shortwave radiation at land surface + REAL, DIMENSION(klon) :: epot_air ! potential air temperature + REAL, DIMENSION(klon) :: tsol_rad, emis_new ! output from interfsol not used + REAL, DIMENSION(klon) :: u0, v0 ! surface speed + REAL, DIMENSION(klon) :: precip_totsnow ! total solid precip + INTEGER :: i,j + CHARACTER (len = 20) :: modname = 'surf_land' + CHARACTER (len = 100) :: abort_message + +!albedo SB >>> + REAL, DIMENSION(klon) :: alb1_new,alb2_new +!albedo SB <<< + +#ifdef ISO + real, parameter :: t_coup = 273.15 + real, dimension(klon) :: fqfonte_diag + real, dimension(klon) :: snow_evap_diag + real, dimension(klon) :: fqcalving_diag + integer :: ixt +#endif +!**************************************************************************************** +!Total solid precip + +IF (ok_bs) THEN +precip_totsnow(:)=precip_snow(:)+precip_bs(:) +ELSE +precip_totsnow(:)=precip_snow(:) +ENDIF +!**************************************************************************************** +#ifdef ISO +#ifdef ISOVERIF +! write(*,*) 'surf_land_mod 162' + do i=1,knon + if (iso_eau.gt.0) then + call iso_verif_egalite_choix(precip_snow(i), & + & xtprecip_snow(iso_eau,i),'surf_land_mod 129', & + & errmax,errmaxrel) + call iso_verif_egalite_choix(qsol(i), & + & xtsol(iso_eau,i),'surf_land_mod 139', & + & errmax,errmaxrel) + endif + enddo +#endif +#ifdef ISOVERIF +! write(*,*) 'surf_land 169: ok_veget=',ok_veget + do i=1,knon + do ixt=1,ntiso + call iso_verif_noNaN(xtprecip_snow(ixt,i),'surf_land 146') + enddo + enddo +#endif +#endif + + +!**************************************************************************************** +! Choice between call to vegetation model (ok_veget=true) or simple calculation below +! +!**************************************************************************************** + IF (ok_veget) THEN +!**************************************************************************************** +! Call model sechiba in model ORCHIDEE +! +!**************************************************************************************** + p1lay_tmp(:) = 0.0 + pref_tmp(:) = 0.0 + p1lay_tmp(1:knon) = p1lay(1:knon)/100. + pref_tmp(1:knon) = pref(1:knon)/100. +! +!* Calculate incoming flux for SW and LW interval: swdown +! + swdown(:) = 0.0 + DO i = 1, knon + swdown(i) = swnet(i)/(1-albedo(i)) + END DO +! +!* Calculate potential air temperature +! + epot_air(:) = 0.0 + DO i = 1, knon + epot_air(i) = RCPD*temp_air(i)*(pref(i)/p1lay(i))**RKAPPA + END DO + +!!SN LMDZORISO +!#ifdef ISO +! CALL abort_physic('surf_land_mod 220','isos pas prevus dans orchidee',1) +!#endif + ! temporary for keeping same results using lwdown_m instead of lwdown + CALL surf_land_orchidee(itime, dtime, date0, knon, & + knindex, rlon, rlat, yrmu0, pctsrf, & + debut, lafin, & + zlev, u1, v1, gustiness, temp_air, spechum, epot_air, ccanopy, & + cdragh, AcoefH, AcoefQ, BcoefH, BcoefQ, & + precip_rain, precip_totsnow, lwdown_m, swnet, swdown, & + pref_tmp, q2m, t2m, & + evap, fluxsens, fluxlat, & + tsol_rad, tsurf_new, alb1_new, alb2_new, & + emis_new, z0m, z0h, qsurf, & + veget, lai, height & +#ifdef ISO + ,xtprecip_rain, xtprecip_snow, & + xtriverflow, xtcoastalflow, xtevap, Rsol & +#endif + ) + +#ifdef ISO +#ifdef ISOVERIF + write(*,*) 'surf_land 193: apres surf_land_orchidee' + do i=1,knon + if (iso_eau.gt.0) then + call iso_verif_egalite_choix(xtevap(iso_eau,i),evap(i), & + & 'surf_land 197',errmax,errmaxrel) + endif !if (iso_eau.gt.0) then + enddo !do i=1,knon +#endif +#endif +! +!* Add contribution of relief to surface roughness +! + DO i=1,knon + z0m(i) = MAX(1.5e-05,SQRT(z0m(i)**2 + rugoro(i)**2)) + ENDDO + + ELSE ! not ok_veget +!**************************************************************************************** +! No extern vegetation model choosen, call simple bucket calculations instead. +! +!**************************************************************************************** +#ifdef ISO +#ifdef ISOVERIF +! write(*,*) 'surf_land 247' + call iso_verif_egalite_vect1D( & + & xtsnow,snow,'surf_land_mod 207',niso,klon) +#endif +#endif + +#ifdef ISO + if (nudge_qsol.eq.1) then + call surf_land_nudge_qsol(knon,rlat,rlon,qsol,xtsol,knindex) + endif + !write(*,*) 'surf_land 258' +#endif + IF (iflag_hetero_surf .GT. 0) THEN + IF (klon .EQ. 1) THEN + ! + CALL surf_land_bucket_hetero(itime, jour, knon, knindex, debut, dtime,& + tsurf, p1lay, cdragh, precip_rain, precip_totsnow, temp_air, & + spechum, AcoefH, AcoefQ, BcoefH, BcoefQ, pref, zlev, & + u1, v1, gustiness, rugoro, swnet, lwnet, & + snow, qsol, agesno, tsoil, & + qsurf, z0m, z0h, alb1_new, alb2_new, evap, & + fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l, & + tsurf_tersrf, tsoil_tersrf, qsurf_tersrf, tsurf_new_tersrf, & + cdragm_tersrf, cdragh_tersrf, & + swnet_tersrf, lwnet_tersrf, fluxsens_tersrf, fluxlat_tersrf) + ELSE + abort_message = 'Heterogeneous continental subsurfaces (iflag_hetero_surf > 0) are only compatible in 1D cases.' + CALL abort_physic(modname,abort_message,1) + ENDIF + ! + ELSE + CALL surf_land_bucket(itime, jour, knon, knindex, debut, dtime,& + tsurf, p1lay, cdragh, precip_rain, precip_totsnow, temp_air, & + spechum, AcoefH, AcoefQ, BcoefH, BcoefQ, pref, & + u1, v1, gustiness, rugoro, swnet, lwnet, & + snow, qsol, agesno, tsoil, & + qsurf, z0m, alb1_new, alb2_new, evap, & + fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l & +#ifdef ISO + ,xtprecip_rain, xtprecip_snow,xtspechum, & + xtsnow, xtsol,xtevap,h1, & + & runoff_diag, xtrunoff_diag,Rland_ice & +#endif + & ) + z0h(1:knon)=z0m(1:knon) ! En attendant mieux + + ENDIF ! iflag_hetero_surf + + ENDIF ! ok_veget + + ! blowing snow not treated yet over land + fluxbs(:)=0. + + +!**************************************************************************************** +! Calculation for all land models +! - Flux calculation at first modele level for U and V +!**************************************************************************************** +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, gustiness, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + +#ifdef ISO +#ifdef ISOVERIF +! write(*,*) 'surf_land 237: sortie' + DO i=1,knon + IF (iso_eau >= 0) THEN + call iso_verif_egalite_choix(xtsnow(iso_eau,i),snow(i), & + & 'surf_land 241',errmax,errmaxrel) + ENDIF !if (iso_eau.gt.0) then + ENDDO !do i=1,knon +#endif +#endif + +!albedo SB >>> + SELECT CASE(NSW) + CASE(2) + alb_dir_new(1:knon,1)=alb1_new(1:knon) + alb_dir_new(1:knon,2)=alb2_new(1:knon) + CASE(4) + alb_dir_new(1:knon,1)=alb1_new(1:knon) + alb_dir_new(1:knon,2)=alb2_new(1:knon) + alb_dir_new(1:knon,3)=alb2_new(1:knon) + alb_dir_new(1:knon,4)=alb2_new(1:knon) + CASE(6) + alb_dir_new(1:knon,1)=alb1_new(1:knon) + alb_dir_new(1:knon,2)=alb1_new(1:knon) + alb_dir_new(1:knon,3)=alb1_new(1:knon) + alb_dir_new(1:knon,4)=alb2_new(1:knon) + alb_dir_new(1:knon,5)=alb2_new(1:knon) + alb_dir_new(1:knon,6)=alb2_new(1:knon) + END SELECT + + alb_dif_new=alb_dir_new +!albedo SB <<< + + END SUBROUTINE surf_land + + +#ifdef ISO + SUBROUTINE surf_land_nudge_qsol(knon,rlat,rlon,qsol,xtsol,knindex) + + USE dimphy + USE infotrac_phy, ONLY: niso + USE isotopes_mod, ONLY: region_nudge_qsol + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(INOUT) :: qsol + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, DIMENSION(niso,klon), INTENT(INOUT) :: xtsol + REAL :: lat_min_nudge_qsol,lat_max_nudge_qsol + REAL :: lon_min_nudge_qsol,lon_max_nudge_qsol + INTEGER :: i,ixt + REAL :: qsol_new + + IF (region_nudge_qsol == 1) THEN + ! Aamzonie du Sud + lat_min_nudge_qsol=-15.0 + lat_max_nudge_qsol=-5.0 + lon_min_nudge_qsol=-70.0 + lon_max_nudge_qsol=-50.0 + ELSE IF (region_nudge_qsol == 2) THEN + ! Aamzonie du Nord + lat_min_nudge_qsol=-5.0 + lat_max_nudge_qsol=5.0 + lon_min_nudge_qsol=-70.0 + lon_max_nudge_qsol=-50.0 + ELSE + WRITE(*,*) 'surf_land 298: cas pas prevu' + WRITE(*,*) 'region_nudge_qsol=',region_nudge_qsol + stop + ENDIF + +! write(*,*) 'surf_land 314: knon=',knon +! write(*,*) 'rlat=',rlat +! write(*,*) 'rlon=',rlon +! write(*,*) 'region_nudge_qsol=',region_nudge_qsol + + DO i=1,knon + IF ((rlat(knindex(i)) >= lat_min_nudge_qsol).and. & + & (rlat(knindex(i)) <= lat_max_nudge_qsol).and. & + & (rlon(knindex(i)) >= lon_min_nudge_qsol).and. & + & (rlon(knindex(i)) <= lon_max_nudge_qsol)) THEN +! write(*,*) 'surf_land 324: bon domaine: rlat,rlon,qsol=', & +! & rlat(knindex(i)),rlon(knindex(i)),qsol(knindex(i)) + qsol_new=qsol(i) + IF (region_nudge_qsol == 1) THEN + qsol_new=max(qsol(i),50.0) + ELSE IF (region_nudge_qsol == 2) THEN + qsol_new=max(qsol(i),120.0) + ELSE !if (region_nudge_qsol.eq.1) then + WRITE(*,*) 'surf_land 317: cas pas prevu' + WRITE(*,*) 'region_nudge_qsol=',region_nudge_qsol + STOP + ENDIF !if (region_nudge_qsol.eq.1) then + IF (qsol(i) > 0.0) THEN + DO ixt=1,niso + xtsol(ixt,i)=xtsol(ixt,i)*qsol_new/qsol(i) + ENDDO + ELSE !IF (qsol(i) > 0.0) THEN + DO ixt=1,niso + xtsol(ixt,i)=0.0 + ENDDO + ENDIF !IF (qsol(i) > 0.0) THEN + qsol(i)=qsol_new + WRITE(*,*) 'surf_land 346: qsol_new=',qsol(i) + ENDIF ! if ((rlat(i).ge.lat_min_nudge_qsol).and. + ENDDO !DO i=1,knon + + END SUBROUTINE surf_land_nudge_qsol +#endif + +! +!**************************************************************************************** +! +END MODULE surf_land_mod +! +!**************************************************************************************** +! Index: LMDZ6/trunk/libf/phylmdiso/surf_land_orchidee_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/surf_land_orchidee_mod.F90 (revision 5943) +++ LMDZ6/trunk/libf/phylmdiso/surf_land_orchidee_mod.F90 (revision 5943) @@ -0,0 +1,941 @@ +! +MODULE surf_land_orchidee_mod +#ifndef ORCHIDEE_NOOPENMP +#ifndef ORCHIDEE_NOZ0H +#ifndef ORCHIDEE_NOFREIN +#ifndef ORCHIDEE_NOUNSTRUCT +#ifndef ORCHIDEE_NOLIC +! +! This module controles the interface towards the model ORCHIDEE. +! +! Compatibility with ORCHIDIEE : +! The current version can be used with ORCHIDEE/trunk from revision 7757. +! This interface is used if none of the cpp keys ORCHIDEE_NOOPENMP, +! ORCHIDEE_NOZ0H, ORCHIDEE_NOFREIN or ORCHIDEE_NOLIC is set. +! +! Subroutines in this module : surf_land_orchidee +! Init_orchidee_index +! Get_orchidee_communicator +! Init_neighbours + + USE dimphy +#ifdef CPP_VEGET + USE intersurf ! module in ORCHIDEE +#endif + USE cpl_mod, ONLY : cpl_send_land_fields, cpl_send_landice_fields + USE surface_data, ONLY : type_ocean, landice_opt + USE geometry_mod, ONLY : dx, dy, boundslon, boundslat,longitude, latitude, cell_area, ind_cell_glo + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para, mpi_root_rank=>mpi_master + USE carbon_cycle_mod, ONLY : nbcf_in_orc, nbcf_out, fields_in, yfields_in, yfields_out, cfname_in, cfname_out + USE nrtype, ONLY : PI + + IMPLICIT NONE + + PRIVATE + PUBLIC :: surf_land_orchidee + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, & + knindex, rlon, rlat, yrmu0, pctsrf, & + debut, lafin, & + plev, u1_lay, v1_lay, gustiness, temp_air, spechum, epot_air, ccanopy, & + tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, & + precip_rain, precip_snow, lwdown, swnet, swdown, & + ps, q2m, t2m, & + evap, fluxsens, fluxlat, & + tsol_rad, tsurf_new, alb1_new, alb2_new, & + emis_new, z0m_new, z0h_new, qsurf, & + veget, lai, height & +#ifdef ISO + ,xtprecip_rain,xtprecip_snow, & + xtriverflow, xtcoastalflow, xtevap, Rsol & +#endif + & ) + + USE mod_surf_para + USE mod_synchro_omp + USE carbon_cycle_mod + USE indice_sol_mod + USE print_control_mod, ONLY: lunout + USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat +#ifdef CPP_VEGET + USE time_phylmdz_mod, ONLY: itau_phy +#endif +#ifdef ISO + USE infotrac_phy, ONLY: niso, ntraciso=>ntiso + USE isotopes_mod, ONLY: ridicule +#ifdef ISOTRAC + USE isotrac_mod, ONLY: index_zone,index_iso, option_traceurs,izone_cont, & +& bassin_map +#endif +#endif + USE yomcst_mod_h + USE dimpft_mod_h +! +! Cette routine sert d'interface entre le modele atmospherique et le +! modele de sol continental. Appel a sechiba +! +! L. Fairhead 02/2000 +! +! input: +! itime numero du pas de temps +! dtime pas de temps de la physique (en s) +! nisurf index de la surface a traiter (1 = sol continental) +! knon nombre de points de la surface a traiter +! knindex index des points de la surface a traiter +! rlon longitudes de la grille entiere +! rlat latitudes de la grille entiere +! pctsrf tableau des fractions de surface de chaque maille +! debut logical: 1er appel a la physique (lire les restart) +! lafin logical: dernier appel a la physique (ecrire les restart) +! (si false calcul simplifie des fluxs sur les continents) +! plev hauteur de la premiere couche (Pa) +! u1_lay vitesse u 1ere couche +! v1_lay vitesse v 1ere couche +! temp_air temperature de l'air 1ere couche +! spechum humidite specifique 1ere couche +! epot_air temp pot de l'air +! ccanopy concentration CO2 canopee, correspond au co2_send de +! carbon_cycle_mod ou valeur constant co2_ppm +! tq_cdrag cdrag +! petAcoef coeff. A de la resolution de la CL pour t +! peqAcoef coeff. A de la resolution de la CL pour q +! petBcoef coeff. B de la resolution de la CL pour t +! peqBcoef coeff. B de la resolution de la CL pour q +! precip_rain precipitation liquide +! precip_snow precipitation solide +! lwdown flux IR descendant a la surface +! swnet flux solaire net +! swdown flux solaire entrant a la surface +! ps pression au sol +! radsol rayonnement net aus sol (LW + SW) +! +! output: +! evap evaporation totale +! fluxsens flux de chaleur sensible +! fluxlat flux de chaleur latente +! tsol_rad +! tsurf_new temperature au sol +! alb1_new albedo in visible SW interval +! alb2_new albedo in near IR interval +! emis_new emissivite +! z0m_new surface roughness for momentum +! z0h_new surface roughness for heat +! qsurf air moisture at surface +!! +! Parametres d'entree +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime + REAL, INTENT(IN) :: dtime + REAL, INTENT(IN) :: date0 + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: debut, lafin + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: yrmu0 ! cosine of solar zenith angle + REAL, DIMENSION(klon), INTENT(IN) :: plev + REAL, DIMENSION(klon), INTENT(IN) :: u1_lay, v1_lay, gustiness + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: epot_air, ccanopy + REAL, DIMENSION(klon), INTENT(IN) :: tq_cdrag + REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef + REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: lwdown, swnet, swdown, ps + REAL, DIMENSION(klon), INTENT(IN) :: q2m, t2m +#ifdef ISO + REAL, DIMENSION(ntraciso,klon), INTENT(IN):: xtprecip_rain, xtprecip_snow +#endif + +! Parametres de sortie +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat, qsurf +!PRSN +#ifdef ISO + REAL, DIMENSION(ntraciso,klon), INTENT(OUT) :: xtriverflow + REAL, DIMENSION(ntraciso,klon), INTENT(OUT) :: xtcoastalflow + REAL, DIMENSION(ntraciso,klon), INTENT(OUT) :: xtevap + REAL, DIMENSION(ntraciso,klon), INTENT(INOUT) :: Rsol +#endif +!PRSN + REAL, DIMENSION(klon), INTENT(OUT) :: tsol_rad, tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new + REAL, DIMENSION(klon), INTENT(OUT) :: emis_new, z0m_new, z0h_new + REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: veget + REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: lai + REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: height + +! Local +!**************************************************************************************** + INTEGER :: ij, jj, igrid, ireal, index, nb + INTEGER :: error + REAL, DIMENSION(klon) :: swdown_vrai + REAL, DIMENSION(klon) :: run_off_lic !! run off from land ice defined in ORCHIDEE, contains calving, melting and liquid precipitation + REAL, DIMENSION(klon) :: run_off_lic_frac !! cell fraction corresponding to run_off_lic + REAL, DIMENSION(klon) :: blowingsnow_flux !! blowing snow flux + CHARACTER (len = 20) :: modname = 'surf_land_orchidee' + CHARACTER (len = 80) :: abort_message + LOGICAL,SAVE :: check = .FALSE. + !$OMP THREADPRIVATE(check) + +! type de couplage dans sechiba +! character (len=10) :: coupling = 'implicit' +! drapeaux controlant les appels dans SECHIBA +! type(control_type), save :: control_in +! Preserved albedo + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: albedo_keep, zlev + !$OMP THREADPRIVATE(albedo_keep,zlev) +! coordonnees geographiques + REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: lalo + !$OMP THREADPRIVATE(lalo) +! boundaries of cells + REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: bounds_lalo + !$OMP THREADPRIVATE(bounds_lalo) +! pts voisins + INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours + !$OMP THREADPRIVATE(neighbours) +! fractions continents + REAL,ALLOCATABLE, DIMENSION(:), SAVE :: contfrac + !$OMP THREADPRIVATE(contfrac) +! resolution de la grille + REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: resolution + !$OMP THREADPRIVATE(resolution) + + REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: lon_scat, lat_scat + !$OMP THREADPRIVATE(lon_scat,lat_scat) + +! area of cells + REAL, ALLOCATABLE, DIMENSION (:), SAVE :: area + !$OMP THREADPRIVATE(area) + + LOGICAL, SAVE :: lrestart_read = .TRUE. + !$OMP THREADPRIVATE(lrestart_read) + LOGICAL, SAVE :: lrestart_write = .FALSE. + !$OMP THREADPRIVATE(lrestart_write) + + REAL, DIMENSION(knon,2) :: albedo_out + +! Pb de nomenclature + REAL, DIMENSION(klon) :: petA_orc, peqA_orc + REAL, DIMENSION(klon) :: petB_orc, peqB_orc +! Pb de correspondances de grilles + INTEGER, DIMENSION(:), SAVE, ALLOCATABLE :: ig, jg + !$OMP THREADPRIVATE(ig,jg) + INTEGER :: indi, indj + INTEGER, SAVE, ALLOCATABLE,DIMENSION(:) :: ktindex + !$OMP THREADPRIVATE(ktindex) + +! Essai cdrag + REAL, DIMENSION(klon) :: cdrag + INTEGER,SAVE :: offset + !$OMP THREADPRIVATE(offset) + + REAL, DIMENSION(klon_glo) :: rlon_g,rlat_g + INTEGER, SAVE :: orch_comm + !$OMP THREADPRIVATE(orch_comm) + + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: coastalflow + !$OMP THREADPRIVATE(coastalflow) + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: riverflow + !$OMP THREADPRIVATE(riverflow) + + INTEGER :: orch_mpi_rank + INTEGER :: orch_mpi_size + INTEGER :: orch_omp_rank + INTEGER :: orch_omp_size + + REAL, ALLOCATABLE, DIMENSION(:) :: longitude_glo + REAL, ALLOCATABLE, DIMENSION(:) :: latitude_glo + REAL, ALLOCATABLE, DIMENSION(:,:) :: boundslon_glo + REAL, ALLOCATABLE, DIMENSION(:,:) :: boundslat_glo + INTEGER, ALLOCATABLE, DIMENSION(:) :: ind_cell_glo_glo + INTEGER, ALLOCATABLE, SAVE,DIMENSION(:) :: ind_cell + !$OMP THREADPRIVATE(ind_cell) + INTEGER :: begin, end +#ifdef ISO + ! profondeur du reservoir pour le calcul de la moyenne glissante + REAL, PARAMETER :: h_sol = 0.1 +#ifdef ISOTRAC + INTEGER, SAVE :: izone_recoit + !$OMP THREADPRIVATE(izone_recoit) +#endif + INTEGER :: i, ixt +#endif +! +! Fin definition +!**************************************************************************************** + + IF (check) WRITE(lunout,*)'Entree ', modname + +! Initialisation + + IF (debut) THEN +! Test of coherence between variable ok_veget and cpp key CPP_VEGET +#ifndef CPP_VEGET + abort_message='Pb de coherence: ok_veget = .true. mais CPP_VEGET = .false.' + CALL abort_physic(modname,abort_message,1) +#endif + + CALL Init_surf_para(knon) + ALLOCATE(ktindex(knon)) + IF ( .NOT. ALLOCATED(albedo_keep)) THEN +!ym ALLOCATE(albedo_keep(klon)) +!ym bizarre que non alloue en knon precedement + ALLOCATE(albedo_keep(knon)) + ALLOCATE(zlev(knon)) + ENDIF +! Pb de correspondances de grilles + ALLOCATE(ig(klon)) + ALLOCATE(jg(klon)) + ig(1) = 1 + jg(1) = 1 + indi = 0 + indj = 2 + DO igrid = 2, klon - 1 + indi = indi + 1 + IF ( indi > nbp_lon) THEN + indi = 1 + indj = indj + 1 + ENDIF + ig(igrid) = indi + jg(igrid) = indj + ENDDO + ig(klon) = 1 + jg(klon) = nbp_lat + + IF ((.NOT. ALLOCATED(area))) THEN + ALLOCATE(area(knon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation area' + CALL abort_physic(modname,abort_message,1) + ENDIF + ENDIF + DO igrid = 1, knon + area(igrid) = cell_area(knindex(igrid)) + ENDDO + + IF (grid_type==unstructured) THEN + + + IF ((.NOT. ALLOCATED(lon_scat))) THEN + ALLOCATE(lon_scat(nbp_lon,nbp_lat), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lon_scat' + CALL abort_physic(modname,abort_message,1) + ENDIF + ENDIF + + IF ((.NOT. ALLOCATED(lat_scat))) THEN + ALLOCATE(lat_scat(nbp_lon,nbp_lat), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lat_scat' + CALL abort_physic(modname,abort_message,1) + ENDIF + ENDIF + CALL Gather(rlon,rlon_g) + CALL Gather(rlat,rlat_g) + + IF (is_mpi_root) THEN + index = 1 + DO jj = 2, nbp_lat-1 + DO ij = 1, nbp_lon + index = index + 1 + lon_scat(ij,jj) = rlon_g(index) + lat_scat(ij,jj) = rlat_g(index) + ENDDO + ENDDO + lon_scat(:,1) = lon_scat(:,2) + lat_scat(:,1) = rlat_g(1) + lon_scat(:,nbp_lat) = lon_scat(:,2) + lat_scat(:,nbp_lat) = rlat_g(klon_glo) + ENDIF + + CALL bcast(lon_scat) + CALL bcast(lat_scat) + + ELSE IF (grid_type==regular_lonlat) THEN + + IF ((.NOT. ALLOCATED(lalo))) THEN + ALLOCATE(lalo(knon,2), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lalo' + CALL abort_physic(modname,abort_message,1) + ENDIF + ENDIF + + IF ((.NOT. ALLOCATED(bounds_lalo))) THEN + ALLOCATE(bounds_lalo(knon,nvertex,2), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lalo' + CALL abort_physic(modname,abort_message,1) + ENDIF + ENDIF + + IF ((.NOT. ALLOCATED(lon_scat))) THEN + ALLOCATE(lon_scat(nbp_lon,nbp_lat), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lon_scat' + CALL abort_physic(modname,abort_message,1) + ENDIF + ENDIF + IF ((.NOT. ALLOCATED(lat_scat))) THEN + ALLOCATE(lat_scat(nbp_lon,nbp_lat), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lat_scat' + CALL abort_physic(modname,abort_message,1) + ENDIF + ENDIF + lon_scat = 0. + lat_scat = 0. + DO igrid = 1, knon + index = knindex(igrid) + lalo(igrid,2) = rlon(index) + lalo(igrid,1) = rlat(index) + bounds_lalo(igrid,:,2)=boundslon(index,:)*180./PI + bounds_lalo(igrid,:,1)=boundslat(index,:)*180./PI + ENDDO + + + + CALL Gather(rlon,rlon_g) + CALL Gather(rlat,rlat_g) + + IF (is_mpi_root) THEN + index = 1 + IF (klon_glo == 1) THEN + lon_scat(:,1) = rlon_g(1) + lat_scat(:,1) = rlat_g(1) + lon_scat(:,nbp_lat) = rlon_g(1) + lat_scat(:,nbp_lat) = rlat_g(klon_glo) + ELSE!FC + DO jj = 2, nbp_lat-1 + DO ij = 1, nbp_lon + index = index + 1 + lon_scat(ij,jj) = rlon_g(index) + lat_scat(ij,jj) = rlat_g(index) + ENDDO + ENDDO + lon_scat(:,1) = lon_scat(:,2) + lat_scat(:,1) = rlat_g(1) + lon_scat(:,nbp_lat) = lon_scat(:,2) + lat_scat(:,nbp_lat) = rlat_g(klon_glo) + ENDIF !FC + + ENDIF + + CALL bcast(lon_scat) + CALL bcast(lat_scat) + + ENDIF +! +! Allouer et initialiser le tableau des voisins et des fraction de continents +! + IF (( .NOT. ALLOCATED(contfrac))) THEN + ALLOCATE(contfrac(knon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation contfrac' + CALL abort_physic(modname,abort_message,1) + ENDIF + ENDIF + + DO igrid = 1, knon + ireal = knindex(igrid) + contfrac(igrid) = pctsrf(ireal,is_ter) + ENDDO + + + IF (grid_type==regular_lonlat) THEN + + IF ( (.NOT.ALLOCATED(neighbours))) THEN + ALLOCATE(neighbours(knon,8), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation neighbours' + CALL abort_physic(modname,abort_message,1) + ENDIF + ENDIF + neighbours = -1. + CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter)) + + ELSE IF (grid_type==unstructured) THEN + + IF ( (.NOT.ALLOCATED(neighbours))) THEN + ALLOCATE(neighbours(knon,12), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation neighbours' + CALL abort_physic(modname,abort_message,1) + ENDIF + ENDIF + neighbours = -1. + + ENDIF + + +! +! Allocation et calcul resolutions + IF ( (.NOT.ALLOCATED(resolution))) THEN + ALLOCATE(resolution(knon,2), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation resolution' + CALL abort_physic(modname,abort_message,1) + ENDIF + ENDIF + + IF (grid_type==regular_lonlat) THEN + DO igrid = 1, knon + ij = knindex(igrid) + resolution(igrid,1) = dx(ij) + resolution(igrid,2) = dy(ij) + PRINT*, 'resolution FCCC',resolution(igrid,1),resolution(igrid,2) + ENDDO + ENDIF + + ALLOCATE(coastalflow(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation coastalflow' + CALL abort_physic(modname,abort_message,1) + ENDIF + + ALLOCATE(riverflow(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation riverflow' + CALL abort_physic(modname,abort_message,1) + ENDIF +! +! carbon_cycle_cpl not possible with this interface and version of ORHCHIDEE +! +! >> PC +! IF (carbon_cycle_cpl) THEN +! abort_message='carbon_cycle_cpl not yet possible with this interface of ORCHIDEE' +! CALL abort_physic(modname,abort_message,1) +! END IF +! << PC + + ENDIF ! (fin debut) + +! +! Appel a la routine sols continentaux +! + IF (lafin) lrestart_write = .TRUE. + IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write + + petA_orc(1:knon) = petBcoef(1:knon) * dtime + petB_orc(1:knon) = petAcoef(1:knon) + peqA_orc(1:knon) = peqBcoef(1:knon) * dtime + peqB_orc(1:knon) = peqAcoef(1:knon) + + cdrag = 0. + cdrag(1:knon) = tq_cdrag(1:knon) + +! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/287.05*temp_air(1:knon))*9.80665) +! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG) + zlev(1:knon) = plev(1:knon)*RD*temp_air(1:knon)/((ps(1:knon)*100.0)*RG) + + +! PF et PASB +! where(cdrag > 0.01) +! cdrag = 0.01 +! endwhere +! write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag) + + + IF (debut) THEN + CALL Init_orchidee_index(knon,knindex,offset,ktindex) + CALL Get_orchidee_communicator(orch_comm,orch_mpi_size,orch_mpi_rank, orch_omp_size,orch_omp_rank) + + IF (grid_type==unstructured) THEN + IF (knon==0) THEN + begin=1 + end=0 + ELSE + begin=offset+1 + end=offset+ktindex(knon) + ENDIF + + IF (orch_mpi_rank==orch_mpi_size-1 .AND. orch_omp_rank==orch_omp_size-1) end=nbp_lon*nbp_lat + + ALLOCATE(lalo(end-begin+1,2)) + ALLOCATE(bounds_lalo(end-begin+1,nvertex,2)) + ALLOCATE(ind_cell(end-begin+1)) + + ALLOCATE(longitude_glo(klon_glo)) + CALL gather(longitude,longitude_glo) + CALL bcast(longitude_glo) + lalo(:,2)=longitude_glo(begin:end)*180./PI + + ALLOCATE(latitude_glo(klon_glo)) + CALL gather(latitude,latitude_glo) + CALL bcast(latitude_glo) + lalo(:,1)=latitude_glo(begin:end)*180./PI + + ALLOCATE(boundslon_glo(klon_glo,nvertex)) + CALL gather(boundslon,boundslon_glo) + CALL bcast(boundslon_glo) + bounds_lalo(:,:,2)=boundslon_glo(begin:end,:)*180./PI + + ALLOCATE(boundslat_glo(klon_glo,nvertex)) + CALL gather(boundslat,boundslat_glo) + CALL bcast(boundslat_glo) + bounds_lalo(:,:,1)=boundslat_glo(begin:end,:)*180./PI + + ALLOCATE(ind_cell_glo_glo(klon_glo)) + CALL gather(ind_cell_glo,ind_cell_glo_glo) + CALL bcast(ind_cell_glo_glo) + ind_cell(:)=ind_cell_glo_glo(begin:end) + + ENDIF + CALL Init_synchro_omp + +!$OMP BARRIER + + IF (knon > 0) THEN +#ifdef CPP_VEGET + CALL Init_intersurf(nbp_lon,nbp_lat,knon,ktindex,offset,orch_omp_size,orch_omp_rank,orch_comm,grid=grid_type) +#endif + ENDIF + + CALL Synchro_omp + + + IF (knon > 0) THEN + +#ifdef CPP_VEGET + + CALL intersurf_initialize_gathered (itime+itau_phy-1, nbp_lon, nbp_lat, knon, ktindex, dtime, & + lrestart_read, lrestart_write, lalo, contfrac, neighbours, resolution, date0, & + zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, & + cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, & + precip_rain, precip_snow, lwdown, swnet, swdown, ps, & + evap, fluxsens, fluxlat, coastalflow, riverflow, & + tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0m_new, & + lon_scat, lat_scat, q2m(1:knon), t2m(1:knon), z0h_new(1:knon), nvm_orch, & + grid=grid_type, bounds_latlon=bounds_lalo, cell_area=area, ind_cell_glo=ind_cell, & + field_out_names=cfname_out, field_in_names=cfname_in(1:nbcf_in_orc), & + coszang=yrmu0(1:knon)) +#endif + ENDIF + + CALL Synchro_omp + + albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. + + ENDIF + +! swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon)) + swdown_vrai(1:knon) = swdown(1:knon) +!$OMP BARRIER + + IF (knon > 0) THEN +#ifdef CPP_VEGET + IF (nvm_orch .NE. nvm_lmdz ) THEN + abort_message='Pb de dimensiosn PFT: nvm_orch et nvm_lmdz differents.' + CALL abort_physic(modname,abort_message,1) + ENDIF + + CALL intersurf_main_gathered (itime+itau_phy, nbp_lon, nbp_lat, knon, ktindex, dtime, & + lrestart_read, lrestart_write, lalo, & + contfrac, neighbours, resolution, date0, & + zlev, u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), & + cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), & + precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), & + evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), & + tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0m_new(1:knon), & + lon_scat, lat_scat, q2m(1:knon), t2m(1:knon), z0h_new(1:knon),& + veget(1:knon,:),lai(1:knon,:),height(1:knon,:),& + fields_out=yfields_out(1:knon,1:nbcf_out), & + fields_in=yfields_in(1:knon,1:nbcf_in_orc), & + coszang=yrmu0(1:knon), run_off_lic=run_off_lic(1:knon), run_off_lic_frac=run_off_lic_frac(1:knon), blowingsnow_flux=blowingsnow_flux(1:knon)) +#endif + ENDIF + + CALL Synchro_omp + + albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. + +!* Send to coupler +! + IF (type_ocean=='couple') THEN + CALL cpl_send_land_fields(itime, knon, knindex, & + riverflow, coastalflow) + IF (landice_opt .GE. 2) THEN + CALL cpl_send_landice_fields(itime, knon, knindex, run_off_lic, run_off_lic_frac) + END IF + ENDIF + + alb1_new(1:knon) = albedo_out(1:knon,1) + alb2_new(1:knon) = albedo_out(1:knon,2) + +! Convention orchidee: positif vers le haut + fluxsens(1:knon) = -1. * fluxsens(1:knon) + fluxlat(1:knon) = -1. * fluxlat(1:knon) + +! evap = -1. * evap + + IF (debut) lrestart_read = .FALSE. + + IF (debut) CALL Finalize_surf_para + +! >> PC +! Decompressing variables into LMDz for the module carbon_cycle_mod +! nbcf_in can be zero, in which case the loop does not operate +! fields_in can then used elsewhere in the model + + fields_in(:,:)=0.0 + + DO nb=1, nbcf_in_orc + DO igrid = 1, knon + ireal = knindex(igrid) + fields_in(ireal,nb)=yfields_in(igrid,nb) + ENDDO + WRITE(*,*) 'surf_land_orchidee_mod --- yfields_in :',cfname_in(nb) + ENDDO +! >> PC + +#ifdef ISO + ! calcul de xtevap, xtcoostalflow, xtriverflow + DO i=1,knon + IF (precip_rain(i)+precip_snow(i).GT.ridicule) THEN + DO ixt=1,niso + ! hsol=10.0 + Rsol(ixt,i)=(h_sol*Rsol(ixt,i) & + & +(xtprecip_rain(ixt,i)+xtprecip_snow(ixt,i))*dtime) & + & /(h_sol+(precip_rain(i)+precip_snow(i))*dtime) + ENDDO !do ixt=1,niso + ENDIF !if (precip_rain(i)+precip_snow(i).gt.ridicule) then + ENDDO !do i=1,knon + + DO i=1,knon + DO ixt=1,niso + xtevap(ixt,i) = evap(i)*Rsol(ixt,i) + xtcoastalflow(ixt,i)= coastalflow(i)*Rsol(ixt,i) + xtriverflow(ixt,i) = riverflow(i)*Rsol(ixt,i) + ENDDO + ENDDO + + IF (niso /= ntraciso) THEN + abort_message='water tagging pas encore pr\E9vu ici' + CALL abort_physic(modname,abort_message,1) + ENDIF + +#ifdef ISOTRAC + IF ((option_traceurs == 20).or.(option_traceurs == 23)) THEN + izone_recoit = bassin_map(knindex(i)) + ELSE + izone_recoit = izone_cont + ENDIF + + DO i=1,knon + DO ixt=niso+1,ntraciso + IF (index_zone(ixt) == izone_recoit) THEN + xtevap(ixt,i) = xtevap(index_iso(ixt),i) + ELSE + xtevap(ixt,i) = 0.0 + ENDIF + ENDDO !do ixt=niso+1,ntraciso + ENDDO +#endif +#endif + + END SUBROUTINE surf_land_orchidee +! +!**************************************************************************************** +! + SUBROUTINE Init_orchidee_index(knon,knindex,offset,ktindex) + USE mod_surf_para + USE mod_grid_phy_lmdz + + INTEGER,INTENT(IN) :: knon + INTEGER,INTENT(IN) :: knindex(klon) + INTEGER,INTENT(OUT) :: offset + INTEGER,INTENT(OUT) :: ktindex(klon) + + INTEGER :: ktindex_glo(knon_glo) + INTEGER :: offset_para(0:omp_size*mpi_size-1) + INTEGER :: LastPoint + INTEGER :: task + + ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1 + + CALL gather_surf(ktindex(1:knon),ktindex_glo) + + IF (is_mpi_root .AND. is_omp_root) THEN + LastPoint=0 + DO Task=0,mpi_size*omp_size-1 + IF (knon_glo_para(Task)>0) THEN + offset_para(task)= LastPoint-MOD(LastPoint,nbp_lon) + LastPoint=ktindex_glo(knon_glo_end_para(task)) + ENDIF + ENDDO + ENDIF + + CALL bcast(offset_para) + + offset=offset_para(omp_size*mpi_rank+omp_rank) + + ktindex(1:knon)=ktindex(1:knon)-offset + + END SUBROUTINE Init_orchidee_index + +! +!************************* *************************************************************** +! + + SUBROUTINE Get_orchidee_communicator(orch_comm, orch_mpi_size, orch_mpi_rank, orch_omp_size,orch_omp_rank) + USE mod_surf_para + USE lmdz_mpi + + INTEGER,INTENT(OUT) :: orch_comm + INTEGER,INTENT(OUT) :: orch_mpi_size + INTEGER,INTENT(OUT) :: orch_mpi_rank + INTEGER,INTENT(OUT) :: orch_omp_size + INTEGER,INTENT(OUT) :: orch_omp_rank + INTEGER :: color + INTEGER :: i,ierr +! +! End definition +!**************************************************************************************** + + IF (is_omp_root) THEN + + IF (knon_mpi==0) THEN + color = 0 + ELSE + color = 1 + ENDIF + + IF (using_mpi) THEN + CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr) + CALL MPI_COMM_SIZE(orch_comm,orch_mpi_size,ierr) + CALL MPI_COMM_RANK(orch_comm,orch_mpi_rank,ierr) + ENDIF + + ENDIF + CALL bcast_omp(orch_comm) + + IF (knon_mpi /= 0) THEN + orch_omp_size=0 + DO i=0,omp_size-1 + IF (knon_omp_para(i) /=0) THEN + orch_omp_size=orch_omp_size+1 + IF (i==omp_rank) orch_omp_rank=orch_omp_size-1 + ENDIF + ENDDO + ENDIF + + END SUBROUTINE Get_orchidee_communicator +! +!**************************************************************************************** +! + + SUBROUTINE Init_neighbours(knon,neighbours,knindex,pctsrf) + USE mod_grid_phy_lmdz + USE mod_surf_para + USE indice_sol_mod + USE lmdz_mpi + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, DIMENSION(klon), INTENT(IN) :: pctsrf + +! Output arguments +!**************************************************************************************** + INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours + +! Local variables +!**************************************************************************************** + INTEGER :: i, igrid, jj, ij, iglob + INTEGER :: ierr, ireal, index + INTEGER, DIMENSION(8,3) :: off_ini + INTEGER, DIMENSION(8) :: offset + INTEGER, DIMENSION(nbp_lon,nbp_lat) :: correspond + INTEGER, DIMENSION(knon_glo) :: ktindex_glo + INTEGER, DIMENSION(knon_glo,8) :: neighbours_glo + REAL, DIMENSION(klon_glo) :: pctsrf_glo + INTEGER :: ktindex(klon) +! +! End definition +!**************************************************************************************** + + ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1 + + CALL gather_surf(ktindex(1:knon),ktindex_glo) + CALL gather(pctsrf,pctsrf_glo) + + IF (is_mpi_root .AND. is_omp_root) THEN + neighbours_glo(:,:)=-1 +! Initialisation des offset +! +! offset bord ouest + off_ini(1,1) = - nbp_lon ; off_ini(2,1) = - nbp_lon + 1 ; off_ini(3,1) = 1 + off_ini(4,1) = nbp_lon + 1 ; off_ini(5,1) = nbp_lon ; off_ini(6,1) = 2 * nbp_lon - 1 + off_ini(7,1) = nbp_lon -1 ; off_ini(8,1) = - 1 +! offset point normal + off_ini(1,2) = - nbp_lon ; off_ini(2,2) = - nbp_lon + 1 ; off_ini(3,2) = 1 + off_ini(4,2) = nbp_lon + 1 ; off_ini(5,2) = nbp_lon ; off_ini(6,2) = nbp_lon - 1 + off_ini(7,2) = -1 ; off_ini(8,2) = - nbp_lon - 1 +! offset bord est + off_ini(1,3) = - nbp_lon ; off_ini(2,3) = - 2 * nbp_lon + 1 ; off_ini(3,3) = - nbp_lon + 1 + off_ini(4,3) = 1 ; off_ini(5,3) = nbp_lon ; off_ini(6,3) = nbp_lon - 1 + off_ini(7,3) = -1 ; off_ini(8,3) = - nbp_lon - 1 +! +! Attention aux poles +! + DO igrid = 1, knon_glo + index = ktindex_glo(igrid) + jj = INT((index - 1)/nbp_lon) + 1 + ij = index - (jj - 1) * nbp_lon + correspond(ij,jj) = igrid + ENDDO +!sonia : Les mailles des voisines doivent etre toutes egales (pour couplage orchidee) + IF (knon_glo == 1) THEN + igrid = 1 + DO i = 1,8 + neighbours_glo(igrid, i) = igrid + ENDDO + ELSE + + DO igrid = 1, knon_glo + iglob = ktindex_glo(igrid) + + IF (MOD(iglob, nbp_lon) == 1) THEN + offset = off_ini(:,1) + ELSE IF(MOD(iglob, nbp_lon) == 0) THEN + offset = off_ini(:,3) + ELSE + offset = off_ini(:,2) + ENDIF + + DO i = 1, 8 + index = iglob + offset(i) + ireal = (MIN(MAX(1, index - nbp_lon + 1), klon_glo)) + IF (pctsrf_glo(ireal) > EPSFRA) THEN + jj = INT((index - 1)/nbp_lon) + 1 + ij = index - (jj - 1) * nbp_lon + neighbours_glo(igrid, i) = correspond(ij, jj) + ENDIF + ENDDO + ENDDO + ENDIF !fin knon_glo == 1 + + ENDIF + + DO i = 1, 8 + CALL scatter_surf(neighbours_glo(:,i),neighbours(1:knon,i)) + ENDDO + END SUBROUTINE Init_neighbours + +! +!**************************************************************************************** +! +#endif +#endif +#endif +#endif +#endif +END MODULE surf_land_orchidee_mod Index: LMDZ6/trunk/libf/phylmdiso/surf_landice_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/surf_landice_mod.F90 (revision 5943) +++ LMDZ6/trunk/libf/phylmdiso/surf_landice_mod.F90 (revision 5943) @@ -0,0 +1,714 @@ +! +MODULE surf_landice_mod + + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_landice(itime, dtime, knon, knindex, & + rlon, rlat, debut, lafin, & + rmu0, lwdownm, albedo, pphi1, & + swnet, lwnet, tsurf, p1lay, & + cdragh, cdragm, precip_rain, precip_snow, precip_bs, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + AcoefQBS, BcoefQBS, & + ps, u1, v1, gustiness, rugoro, pctsrf, & + snow, qsurf, qsol, qbs1, agesno, & + tsoil, z0m, z0h, SFRWL, alb_dir, alb_dif, evap, icesub_lic, fluxsens, fluxlat, fluxbs, & + tsurf_new, dflux_s, dflux_l, & + alt, slope, cloudf, & + snowhgt, qsnow, to_ice, sissnow, & + alb3, runoff, & + flux_u1, flux_v1 & +#ifdef ISO + & ,xtprecip_rain, xtprecip_snow,xtspechum,Rland_ice & + & ,xtsnow,xtsol,xtevap & +#endif + & ) + + USE dimphy + USE geometry_mod, ONLY : longitude,latitude + USE surface_data, ONLY : type_ocean, calice, calsno, landice_opt, iflag_albcalc + USE fonte_neige_mod, ONLY : fonte_neige,run_off_lic,fqcalving_global,ffonte_global,fqfonte_global,runofflic_global + USE cpl_mod, ONLY : cpl_send_landice_fields + USE calcul_fluxs_mod + USE phys_local_var_mod, ONLY : zxrhoslic, zxustartlic, zxqsaltlic, tempsmoothlic + USE phys_output_var_mod, ONLY : snow_o,zfra_o +#ifdef ISO + USE fonte_neige_mod, ONLY : xtrun_off_lic + USE infotrac_phy, ONLY : ntiso,niso + USE isotopes_routines_mod, ONLY: calcul_iso_surf_lic_vectall +#ifdef ISOVERIF + USE isotopes_mod, ONLY: iso_eau,ridicule + USE isotopes_verif_mod +#endif +#endif + + USE clesphys_mod_h + USE yomcst_mod_h + USE ioipsl_getin_p_mod, ONLY : getin_p + USE lmdz_blowing_snow_ini, ONLY : c_esalt_bs, zeta_bs, pbst_bs, prt_bs, rhoice_bs, rhohard_bs + USE lmdz_blowing_snow_ini, ONLY : rhofresh_bs, tau_eqsalt_bs, tau_dens0_bs, tau_densmin_bs + USE surf_inlandsis_mod, ONLY : surf_inlandsis + + USE indice_sol_mod + USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INLANDSIS + USE dimsoil_mod_h, ONLY: nsoilmx + + + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, knon + INTEGER, DIMENSION(klon), INTENT(in) :: knindex + REAL, INTENT(in) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: swnet ! net shortwave radiance + REAL, DIMENSION(klon), INTENT(IN) :: lwnet ! net longwave radiance + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow, precip_bs + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: AcoefQBS, BcoefQBS + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, gustiness, qbs1 + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf +#ifdef ISO + REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtprecip_rain, xtprecip_snow + REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtspechum +#endif + + + LOGICAL, INTENT(IN) :: debut !true if first step + LOGICAL, INTENT(IN) :: lafin !true if last step + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: rmu0 + REAL, DIMENSION(klon), INTENT(IN) :: lwdownm !ylwdown + REAL, DIMENSION(klon), INTENT(IN) :: albedo !mean albedo + REAL, DIMENSION(klon), INTENT(IN) :: pphi1 + REAL, DIMENSION(klon), INTENT(IN) :: alt !mean altitude of the grid box + REAL, DIMENSION(klon), INTENT(IN) :: slope !mean slope in grid box + REAL, DIMENSION(klon), INTENT(IN) :: cloudf !total cloud fraction + +! In/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil +#ifdef ISO + REAL, DIMENSION(niso,klon), INTENT(INOUT) :: xtsnow, xtsol + REAL, DIMENSION(niso,klon), INTENT(INOUT) :: Rland_ice +#endif + + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: z0m, z0h +!albedo SB >>> +! REAL, DIMENSION(klon), INTENT(OUT) :: alb1 ! new albedo in visible SW interval +! REAL, DIMENSION(klon), INTENT(OUT) :: alb2 ! new albedo in near IR interval + REAL, DIMENSION(6), INTENT(IN) :: SFRWL + REAL, DIMENSION(klon,nsw), INTENT(OUT) :: alb_dir,alb_dif +!albedo SB <<< + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat, icesub_lic + REAL, DIMENSION(klon), INTENT(OUT) :: fluxbs + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + + REAL, DIMENSION(klon), INTENT(OUT) :: alb3 + REAL, DIMENSION(klon), INTENT(OUT) :: qsnow !column water in snow [kg/m2] + REAL, DIMENSION(klon), INTENT(OUT) :: snowhgt !Snow height (m) + REAL, DIMENSION(klon), INTENT(OUT) :: to_ice + REAL, DIMENSION(klon), INTENT(OUT) :: sissnow + REAL, DIMENSION(klon), INTENT(OUT) :: runoff !Land ice runoff +#ifdef ISO + REAL, DIMENSION(ntiso,klon), INTENT(OUT) :: xtevap +#endif + + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: soilcap, soilflux + REAL, DIMENSION(klon) :: cal, beta, dif_grnd + REAL, DIMENSION(klon) :: zfra, alb_neig + REAL, DIMENSION(klon) :: radsol + REAL, DIMENSION(klon) :: u0, v0, u1_lay, v1_lay, ustar + INTEGER :: i,j,nt + REAL, DIMENSION(klon) :: fqfonte,ffonte + REAL, DIMENSION(klon) :: run_off_lic_frac +#ifdef ISO + REAL, PARAMETER :: t_coup = 273.15 + REAL, DIMENSION(klon) :: fqfonte_diag + REAL, DIMENSION(klon) :: fq_fonte_diag + REAL, DIMENSION(klon) :: snow_evap_diag + REAL, DIMENSION(klon) :: fqcalving_diag + REAL max_eau_sol_diag + REAL, DIMENSION(klon) :: runoff_diag + REAL, DIMENSION(klon) :: run_off_lic_diag + REAL :: coeff_rel_diag + INTEGER :: ixt + REAL, DIMENSION(niso,klon) :: xtsnow_prec,xtsol_prec + REAL, DIMENSION(klon) :: snow_prec,qsol_prec +#endif + + + REAL, DIMENSION(klon) :: emis_new !Emissivity + REAL, DIMENSION(klon) :: swdown,lwdown + REAL, DIMENSION(klon) :: precip_snow_adv, snow_adv !Snow Drift precip./advection (not used in inlandsis) + REAL, DIMENSION(klon) :: erod !erosion of surface snow (flux, kg/m2/s like evap) + REAL, DIMENSION(klon) :: zsl_height, wind_velo !surface layer height, wind spd + REAL, DIMENSION(klon) :: dens_air, snow_cont_air !air density; snow content air + REAL, DIMENSION(klon) :: alb_soil !albedo of underlying ice + REAL, DIMENSION(klon) :: pexner !Exner potential + REAL :: pref + REAL, DIMENSION(klon,nsoilmx) :: tsoil0 !modif + REAL :: dtis ! subtimestep + LOGICAL :: debut_is, lafin_is ! debut and lafin for inlandsis + + CHARACTER (len = 20) :: modname = 'surf_landice' + CHARACTER (len = 80) :: abort_message + + + REAL,DIMENSION(klon) :: alb1,alb2 + REAL :: time_tempsmooth,coef_tempsmooth + REAL,DIMENSION(klon) :: precip_totsnow, evap_totsnow + REAL, DIMENSION (klon,6) :: alb6 + REAL :: esalt + REAL :: lambdasalt,fluxsalt, csalt, nunu, aa, bb, cc + REAL :: tau_dens, maxerosion + REAL, DIMENSION(klon) :: ws1, rhod, rhos, ustart0, ustart, qsalt, hsalt + REAL, DIMENSION(klon) :: fluxbs_1, fluxbs_2, bsweight_fresh + LOGICAL, DIMENSION(klon) :: ok_remaining_freshsnow + REAL :: ta1, ta2, ta3, z01, z02, z03, coefa, coefb, coefc, coefd + + +! End definition +!**************************************************************************************** +!FC +!FC + REAL,SAVE :: alb_vis_sno_lic + !$OMP THREADPRIVATE(alb_vis_sno_lic) + REAL,SAVE :: alb_nir_sno_lic + !$OMP THREADPRIVATE(alb_nir_sno_lic) + LOGICAL, SAVE :: firstcall = .TRUE. + !$OMP THREADPRIVATE(firstcall) + + +!FC firtscall initializations +!****************************************************************************************** +#ifdef ISO +#ifdef ISOVERIF +! write(*,*) 'surf_land_ice 1499' + DO i=1,knon + IF (iso_eau > 0) THEN + CALL iso_verif_egalite_choix(xtsnow(iso_eau,i),snow(i), & + & 'surf_land_ice 126',errmax,errmaxrel) + ENDIF !IF (iso_eau > 0) THEN + ENDDO !DO i=1,knon +#endif +#endif + + IF (firstcall) THEN + alb_vis_sno_lic=0.77 + CALL getin_p('alb_vis_sno_lic',alb_vis_sno_lic) + PRINT*, 'alb_vis_sno_lic',alb_vis_sno_lic + alb_nir_sno_lic=0.77 + CALL getin_p('alb_nir_sno_lic',alb_nir_sno_lic) + PRINT*, 'alb_nir_sno_lic',alb_nir_sno_lic + + DO j=1,knon + i = knindex(j) + tempsmoothlic(i) = temp_air(j) + ENDDO + firstcall=.false. + ENDIF +!****************************************************************************************** + +! Initialize output variables + alb3(:) = 999999. + alb2(:) = 999999. + alb1(:) = 999999. + fluxbs(:)=0. + runoff(:) = 0. +!**************************************************************************************** +! Calculate total absorbed radiance at surface +! +!**************************************************************************************** + radsol(:) = 0.0 + radsol(1:knon) = swnet(1:knon) + lwnet(1:knon) + +!**************************************************************************************** + +!**************************************************************************************** +! landice_opt = 0 : soil_model, calcul_flux, fonte_neige, ... +! landice_opt = 1 : prepare and call INterace Lmdz SISvat (INLANDSIS) +! landice_opt = 2 : skip surf_landice and use orchidee over all land surfaces +!**************************************************************************************** + + + IF (landice_opt .EQ. 1) THEN + +!**************************************************************************************** +! CALL to INLANDSIS interface +!**************************************************************************************** +IF (CPPKEY_INLANDSIS) THEN + +#ifdef ISO + CALL abort_physic('surf_landice 235','isotopes pas dans INLANDSIS',1) +#endif + + debut_is=debut + lafin_is=.false. + ! Suppose zero surface speed + u0(:) = 0.0 + v0(:) = 0.0 + + + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, gustiness, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + + + ! Set constants and compute some input for SISVAT + ! = 1000 hPa + ! and calculate incoming flux for SW and LW interval: swdown, lwdown + swdown(:) = 0.0 + lwdown(:) = 0.0 + snow_cont_air(:) = 0. ! the snow content in air is not a prognostic variable of the model + alb_soil(:) = 0.4 ! before albedo(:) but here it is the ice albedo that we have to set + ustar(:) = 0. + pref = 100000. + DO i = 1, knon + swdown(i) = swnet(i)/(1-albedo(i)) + lwdown(i) = lwdownm(i) + wind_velo(i) = u1(i)**2 + v1(i)**2 + wind_velo(i) = wind_velo(i)**0.5 + pexner(i) = (p1lay(i)/pref)**(RD/RCPD) + dens_air(i) = p1lay(i)/RD/temp_air(i) ! dry air density + zsl_height(i) = pphi1(i)/RG + tsoil0(i,:) = tsoil(i,:) + ustar(i)= (cdragm(i)*(wind_velo(i)**2))**0.5 + END DO + + + + dtis=dtime + + IF (lafin) THEN + lafin_is=.true. + END IF + + CALL surf_inlandsis(knon, rlon, rlat, knindex, itime, dtis, debut_is, lafin_is,& + rmu0, swdown, lwdown, albedo, pexner, ps, p1lay, precip_rain, precip_snow, & + zsl_height, wind_velo, ustar, temp_air, dens_air, spechum, tsurf,& + rugoro, snow_cont_air, alb_soil, alt, slope, cloudf, & + radsol, qsol, tsoil0, snow, zfra, snowhgt, qsnow, to_ice, sissnow,agesno, & + AcoefH, AcoefQ, BcoefH, BcoefQ, cdragm, cdragh, & + run_off_lic, fqfonte, ffonte, evap, erod, fluxsens, fluxlat,dflux_s, dflux_l, & + tsurf_new, alb1, alb2, alb3, alb6, & + emis_new, z0m, z0h, qsurf) + + debut_is=.false. + + + ! Treatment of snow melting and calving + + ! for consistency with standard LMDZ, add calving to run_off_lic + run_off_lic(:)=run_off_lic(:) + to_ice(:) + + DO i = 1, knon + ffonte_global(knindex(i),is_lic) = ffonte(i) + fqfonte_global(knindex(i),is_lic) = fqfonte(i)! net melting= melting - refreezing + fqcalving_global(knindex(i),is_lic) = to_ice(i) ! flux + runofflic_global(knindex(i)) = run_off_lic(i) + ENDDO + ! Here, we assume that the calving term is equal to the to_ice term + ! (no ice accumulation) + + +ELSE + abort_message='Pb de coherence: landice_opt = 1 mais CPP_INLANDSIS = .false.' + CALL abort_physic(modname,abort_message,1) +END IF + + + ELSE + +!**************************************************************************************** +! Soil calculations +! +!**************************************************************************************** + + ! EV: use calbeta + CALL calbeta(dtime, is_lic, knon, snow, qsol, beta, cal, dif_grnd) + + + ! use soil model and recalculate properly cal + IF (soil_model) THEN + CALL soil(dtime, is_lic, knon, snow, tsurf, qsol, & + & longitude(knindex(1:knon)), latitude(knindex(1:knon)), tsoil, soilcap, soilflux) + cal(1:knon) = RCPD / soilcap(1:knon) + radsol(1:knon) = radsol(1:knon) + soilflux(1:knon) + ELSE + cal = RCPD * calice + WHERE (snow > 0.0) cal = RCPD * calsno + ENDIF + + +!**************************************************************************************** +! Calulate fluxes +! +!**************************************************************************************** + +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + + CALL calcul_fluxs(knon, is_lic, dtime, & + tsurf, p1lay, cal, beta, cdragh, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, & + 1.,AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + +#ifdef ISO +#ifdef ISOVERIF + DO i=1,knon + IF (iso_eau > 0) THEN + IF (snow(i) > ridicule) THEN + CALL iso_verif_egalite_choix(xtsnow(iso_eau,i),snow(i), & + & 'surf_land_ice 1151',errmax,errmaxrel) + ENDIF !IF ((snow(i) > ridicule)) THEN + ENDIF !IF (iso_eau > 0) THEN + ENDDO !DO i=1,knon +#endif + + DO i=1,knon + snow_prec(i)=snow(i) + DO ixt=1,niso + xtsnow_prec(ixt,i)=xtsnow(ixt,i) + ENDDO !DO ixt=1,niso + ! initialisation: + fq_fonte_diag(i)=0.0 + fqfonte_diag(i)=0.0 + snow_evap_diag(i)=0.0 + ENDDO !DO i=1,knon +#endif + + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, gustiness, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + + +!**************************************************************************************** +! Calculate albedo +! +!**************************************************************************************** + +! Attantion: alb1 and alb2 are not the same! + alb1(1:knon) = alb_vis_sno_lic + alb2(1:knon) = alb_nir_sno_lic + + +!**************************************************************************************** +! Rugosity +! +!**************************************************************************************** + +if (z0m_landice .GT. 0.) then + z0m(1:knon) = z0m_landice + z0h(1:knon) = z0m_landice*ratio_z0hz0m_landice +else + ! parameterization of z0=f(T) following measurements in Adelie Land by Amory et al 2017 + coefa = 0.1658 !0.1862 !Ant + coefb = -50.3869 !-55.7718 !Ant + ta1 = 253.15 !255. Ant + ta2 = 273.15 + ta3 = 273.15+3 + z01 = exp(coefa*ta1 + coefb) !~0.2 ! ~0.25 mm + z02 = exp(coefa*ta2 + coefb) !~6 !~7 mm + z03 = z01 + coefc = log(z03/z02)/(ta3-ta2) + coefd = log(z03)-coefc*ta3 + time_tempsmooth=2.*86400. + coef_tempsmooth=min(1.,dtime/time_tempsmooth) + !coef_tempsmooth=0. + do j=1,knon + i=knindex(j) + tempsmoothlic(i)=temp_air(j)*coef_tempsmooth+tempsmoothlic(i)*(1.-coef_tempsmooth) + if (tempsmoothlic(i) .lt. ta1) then + z0m(j) = z01 + else if (tempsmoothlic(i).ge.ta1 .and. tempsmoothlic(i).lt.ta2) then + z0m(j) = exp(coefa*tempsmoothlic(i) + coefb) + else if (tempsmoothlic(i).ge.ta2 .and. tempsmoothlic(i).lt.ta3) then + ! if st > 0, melting induce smooth surface + z0m(j) = exp(coefc*tempsmoothlic(i) + coefd) + else + z0m(j) = z03 + endif + z0h(j)=z0m(j) + enddo + +endif + + +!**************************************************************************************** +! Simple blowing snow param +!**************************************************************************************** +! we proceed in 2 steps: +! first we erode - if possible -the accumulated snow during the time step +! then we update the density of the underlying layer and see if we can also erode +! this layer + + + if (ok_bs) then + fluxbs(:)=0. + do j=1,knon + ws1(j)=(u1(j)**2+v1(j)**2)**0.5 + ustar(j)=(cdragm(j)*(u1(j)**2+v1(j)**2))**0.5 + rhod(j)=p1lay(j)/RD/temp_air(j) + ustart0(j) =(log(2.868)-log(1.625))/0.085*sqrt(cdragm(j)) + enddo + + ! 1st step: erosion of fresh snow accumulated during the time step + do j=1, knon + if (precip_snow(j) .GT. 0.) then + rhos(j)=rhofresh_bs + ! blowing snow flux formula used in MAR + ustart(j)=ustart0(j)*exp(max(rhoice_bs/rhofresh_bs-rhoice_bs/rhos(j),0.))*exp(max(0.,rhos(j)-rhohard_bs)) + ! we have multiplied by exp to prevent erosion when rhos>rhohard_bs + ! computation of qbs at the top of the saltation layer + ! default formulation from MAR model (Amory et al. 2021, Gallee et al. 2001) + esalt=1./(c_esalt_bs*max(1.e-6,ustar(j))) + hsalt(j)=0.08436*(max(1.e-6,ustar(j))**1.27) + qsalt(j)=(max(ustar(j)**2-ustart(j)**2,0.))/(RG*hsalt(j))*esalt + ! calculation of erosion (flux positive towards the surface here) + ! consistent with implicit resolution of turbulent mixing equation + ! Nemoto and Nishimura 2004 show that steady-state saltation is achieved within a time tau_eqsalt_bs of about 10s + ! we thus prevent snowerosion (snow particle transfer from the saltation layer to the first model level) + ! integrated over tau_eqsalt_bs to exceed the total mass of snow particle in the saltation layer + ! (rho*qsalt*hsalt) + ! during this first step we also lower bound the erosion to the amount of fresh snow accumulated during the time step + maxerosion=min(precip_snow(j),hsalt(j)*qsalt(j)*rhod(j)/tau_eqsalt_bs) + + fluxbs_1(j)=rhod(j)*ws1(j)*cdragh(j)*zeta_bs*(AcoefQBS(j)-qsalt(j)) & + / (1.-rhod(j)*ws1(j)*cdragh(j)*zeta_bs*BcoefQBS(j)*dtime) + fluxbs_1(j)=max(-maxerosion,fluxbs_1(j)) + + if (precip_snow(j) .gt. abs(fluxbs_1(j))) then + ok_remaining_freshsnow(j)=.true. + bsweight_fresh(j)=1. + else + ok_remaining_freshsnow(j)=.false. + bsweight_fresh(j)=exp(-(abs(fluxbs_1(j))-precip_snow(j))/precip_snow(j)) + endif + else + ok_remaining_freshsnow(j)=.false. + fluxbs_1(j)=0. + bsweight_fresh(j)=0. + endif + enddo + + + ! we now compute the snow age of the overlying layer (snow surface after erosion of the fresh snow accumulated during the time step) + ! this is done through the routine albsno + CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:)+fluxbs_1(:)) + + ! 2nd step: + ! computation of threshold friction velocity + ! which depends on surface snow density + do j = 1, knon + if (ok_remaining_freshsnow(j)) then + fluxbs_2(j)=0. + else + ! we start eroding the underlying layer + ! estimation of snow density + ! snow density increases with snow age and + ! increases even faster in case of sedimentation of blowing snow or rain + tau_dens=max(tau_densmin_bs, tau_dens0_bs*exp(-abs(precip_bs(j))/pbst_bs - & + abs(precip_rain(j))/prt_bs)*exp(-max(tsurf(j)-RTT,0.))) + rhos(j)=rhofresh_bs+(rhohard_bs-rhofresh_bs)*(1.-exp(-agesno(j)*86400.0/tau_dens)) + ! blowing snow flux formula used in MAR + ustart(j)=ustart0(j)*exp(max(rhoice_bs/rhofresh_bs-rhoice_bs/rhos(j),0.))*exp(max(0.,rhos(j)-rhohard_bs)) + ! we have multiplied by exp to prevent erosion when rhos>rhohard_bs + ! computation of qbs at the top of the saltation layer + ! default formulation from MAR model (Amory et al. 2021, Gallee et al. 2001) + esalt=1./(c_esalt_bs*max(1.e-6,ustar(j))) + hsalt(j)=0.08436*(max(1.e-6,ustar(j))**1.27) + qsalt(j)=(max(ustar(j)**2-ustart(j)**2,0.))/(RG*hsalt(j))*esalt + ! calculation of erosion (flux positive towards the surface here) + ! consistent with implicit resolution of turbulent mixing equation + ! Nemoto and Nishimura 2004 show that steady-state saltation is achieved within a time tau_eqsalt_bs of about 10s + ! we thus prevent snowerosion (snow particle transfer from the saltation layer to the first model level) + ! integrated over tau_eqsalt_bs to exceed the total mass of snow particle in the saltation layer + ! (rho*qsalt*hsalt) + maxerosion=hsalt(j)*qsalt(j)*rhod(j)/tau_eqsalt_bs + fluxbs_2(j)=rhod(j)*ws1(j)*cdragh(j)*zeta_bs*(AcoefQBS(j)-qsalt(j)) & + / (1.-rhod(j)*ws1(j)*cdragh(j)*zeta_bs*BcoefQBS(j)*dtime) + fluxbs_2(j)=max(-maxerosion,fluxbs_2(j)) + endif + enddo + + + + + ! final flux and outputs + do j=1, knon + ! total flux is the erosion of fresh snow + + ! a fraction of the underlying snow (if all the fresh snow has been eroded) + ! the calculation of the fraction is quite delicate since we do not know + ! how much time was needed to erode the fresh snow. We assume that this time + ! is dt*exp(-(abs(fluxbs1)-precipsnow)/precipsnow)=dt*bsweight_fresh + + fluxbs(j)=fluxbs_1(j)+fluxbs_2(j)*(1.-bsweight_fresh(j)) + i = knindex(j) + zxustartlic(i) = ustart(j) + zxrhoslic(i) = rhos(j) + zxqsaltlic(i)=qsalt(j) + enddo + + + else ! not ok_bs + ! those lines are useful to calculate the snow age + CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:)) + + endif ! if ok_bs + + + +!**************************************************************************************** +! Calculate snow amount +! +!**************************************************************************************** + IF (ok_bs) THEN + precip_totsnow(:)=precip_snow(:)+precip_bs(:) + evap_totsnow(:)=evap(:)-fluxbs(:) ! flux bs is positive towards the surface (snow erosion) + ELSE + precip_totsnow(:)=precip_snow(:) + evap_totsnow(:)=evap(:) + ENDIF + + + CALL fonte_neige(knon, is_lic, knindex, dtime, & + tsurf, precip_rain, precip_totsnow, & + snow, qsol, tsurf_new, evap_totsnow, icesub_lic & +#ifdef ISO + & ,fq_fonte_diag,fqfonte_diag,snow_evap_diag,fqcalving_diag & + & ,max_eau_sol_diag,runoff_diag,run_off_lic_diag,coeff_rel_diag & +#endif + & ) + + +#ifdef ISO +#ifdef ISOVERIF + DO i=1,knon + IF (iso_eau > 0) THEN + CALL iso_verif_egalite_choix(Rland_ice(iso_eau,i),1.0, & + & 'surf_landice_mod 217',errmax,errmaxrel) + ENDIF !IF (iso_eau > 0) THEN + ENDDO !DO i=1,knon +#endif + + CALL calcul_iso_surf_lic_vectall(klon,knon, & + & evap,snow_evap_diag,Tsurf_new,snow, & + & fq_fonte_diag,fqfonte_diag,dtime,t_coup, & + & precip_snow,xtprecip_snow,precip_rain,xtprecip_rain, snow_prec,xtsnow_prec, & + & xtspechum,spechum,ps,Rland_ice, & + & xtevap,xtsnow,fqcalving_diag, & + & knindex,is_lic,run_off_lic_diag,coeff_rel_diag & + & ) + +! call fonte_neige_export_xtrun_off_lic_0(knon,xtrun_off_lic_0_diag) + +#endif + + WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0. + zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0))) + + + END IF ! landice_opt + + +!**************************************************************************************** +! Send run-off on land-ice to coupler if coupled ocean. +! run_off_lic has been calculated in fonte_neige or surf_inlandsis +! If landice_opt>=2, corresponding call is done from surf_land_orchidee +!**************************************************************************************** + IF (type_ocean=='couple' .AND. landice_opt .LT. 2) THEN + ! Compress fraction where run_off_lic is active (here all pctsrf(is_lic)) + run_off_lic_frac(:)=0.0 + DO j = 1, knon + i = knindex(j) + run_off_lic_frac(j) = pctsrf(i,is_lic) + ENDDO + + CALL cpl_send_landice_fields(itime, knon, knindex, run_off_lic, run_off_lic_frac) + ENDIF + + ! transfer runoff rate [kg/m2/s](!) to physiq for output + runoff(1:knon)=run_off_lic(1:knon)/dtime + + snow_o=0. + zfra_o = 0. + DO j = 1, knon + i = knindex(j) + snow_o(i) = snow(j) + zfra_o(i) = zfra(j) + ENDDO + + +!albedo SB >>> + select case(NSW) + case(2) + alb_dir(1:knon,1)=alb1(1:knon) + alb_dir(1:knon,2)=alb2(1:knon) + case(4) + alb_dir(1:knon,1)=alb1(1:knon) + alb_dir(1:knon,2)=alb2(1:knon) + alb_dir(1:knon,3)=alb2(1:knon) + alb_dir(1:knon,4)=alb2(1:knon) + case(6) + alb_dir(1:knon,1)=alb1(1:knon) + alb_dir(1:knon,2)=alb1(1:knon) + alb_dir(1:knon,3)=alb1(1:knon) + alb_dir(1:knon,4)=alb2(1:knon) + alb_dir(1:knon,5)=alb2(1:knon) + alb_dir(1:knon,6)=alb2(1:knon) + + IF ((landice_opt .EQ. 1) .AND. (iflag_albcalc .EQ. 2)) THEN + alb_dir(1:knon,1)=alb6(1:knon,1) + alb_dir(1:knon,2)=alb6(1:knon,2) + alb_dir(1:knon,3)=alb6(1:knon,3) + alb_dir(1:knon,4)=alb6(1:knon,4) + alb_dir(1:knon,5)=alb6(1:knon,5) + alb_dir(1:knon,6)=alb6(1:knon,6) + ENDIF + + end select +alb_dif=alb_dir +!albedo SB <<< + + + END SUBROUTINE surf_landice +! +!**************************************************************************************** +! +END MODULE surf_landice_mod + + + Index: LMDZ6/trunk/libf/phylmdiso/surf_ocean_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/surf_ocean_mod.F90 (revision 5943) +++ LMDZ6/trunk/libf/phylmdiso/surf_ocean_mod.F90 (revision 5943) @@ -0,0 +1,414 @@ +! +! $Id: surf_ocean_mod.F90 5662 2025-05-20 14:24:41Z fairhead $ +! +MODULE surf_ocean_mod + + IMPLICIT NONE + +CONTAINS + ! + !****************************************************************************** + ! + SUBROUTINE surf_ocean(rlon, rlat, swnet, lwnet, alb1, & + windsp, rmu0, fder, tsurf_in, & + itime, dtime, jour, knon, knindex, & + p1lay, z1lay, cdragh, cdragm, precip_rain, precip_snow, precip_bs, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, gustiness, rugoro, pctsrf, & + snow, qsurf, agesno, & + z0m, z0h, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, & + tsurf_new, dflux_s, dflux_l, lmt_bils, & + flux_u1, flux_v1, delta_sst, delta_sal, ds_ns, dt_ns, dter, dser, & +!GG dt_ds, tkt, tks, taur, sss) + dt_ds, tkt, tks, taur, sss, & + dthetadz300,Ampl & +!GG +#ifdef ISO + & ,xtprecip_rain, xtprecip_snow,xtspechum,Roce, & + & xtsnow,xtevap,h1 & +#endif + & ) + + use albedo, only: alboc, alboc_cd + use bulk_flux_m, only: bulk_flux + USE dimphy, ONLY: klon, zmasq + USE surface_data, ONLY : type_ocean + USE ocean_forced_mod, ONLY : ocean_forced_noice + USE ocean_slab_mod, ONLY : ocean_slab_noice + USE ocean_cpl_mod, ONLY : ocean_cpl_noice + USE indice_sol_mod, ONLY : nbsrf, is_oce +#ifdef ISO + USE infotrac_phy, ONLY : ntraciso=>ntiso,niso +#ifdef ISOVERIF + USE isotopes_mod, ONLY: iso_eau,ridicule + USE isotopes_verif_mod +#endif +#endif + USE clesphys_mod_h + USE yomcst_mod_h +USE limit_read_mod + USE config_ocean_skin_m, ONLY: activate_ocean_skin + ! + ! This subroutine will make a call to ocean_XXX_noice according to the ocean mode (force, + ! slab or couple). The calculations of albedo and rugosity for the ocean surface are + ! done in here because they are identical for the different modes of ocean. + + + + + ! for cycle_diurne and for iflag_z0_oce==-1 (prescribed z0) + + ! Input variables + !****************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: swnet ! net shortwave radiation at surface + REAL, DIMENSION(klon), INTENT(IN) :: lwnet ! net longwave radiation at surface + REAL, DIMENSION(klon), INTENT(IN) :: alb1 ! albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(IN) :: windsp ! wind at 10 m, in m s-1 + REAL, DIMENSION(klon), INTENT(IN) :: rmu0 + REAL, DIMENSION(klon), INTENT(IN) :: fder + REAL, DIMENSION(klon), INTENT(IN) :: tsurf_in ! defined only for subscripts 1:knon + REAL, DIMENSION(klon), INTENT(IN) :: p1lay,z1lay ! pression (Pa) et altitude (m) du premier niveau + REAL, DIMENSION(klon), INTENT(IN) :: cdragh + REAL, DIMENSION(klon), INTENT(IN) :: cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow, precip_bs + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, gustiness + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf +#ifdef ISO + REAL, DIMENSION(ntraciso,klon), INTENT(IN) :: xtprecip_rain, xtprecip_snow + REAL, DIMENSION(ntraciso,klon), INTENT(IN) :: xtspechum +#endif + + ! In/Output variables + !****************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + REAL, DIMENSION(klon), INTENT(INOUT) :: qsurf + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon), INTENT(inOUT) :: z0h +#ifdef ISO + REAL, DIMENSION(niso,klon), INTENT(IN) :: xtsnow + REAL, DIMENSION(niso,klon), INTENT(INOUT):: Roce +#endif + + REAL, intent(inout):: delta_sst(:) ! (knon) + ! Ocean-air interface temperature minus bulk SST, in K. Defined + ! only if activate_ocean_skin >= 1. + + real, intent(inout):: delta_sal(:) ! (knon) + ! Ocean-air interface salinity minus bulk salinity, in ppt. Defined + ! only if activate_ocean_skin >= 1. + + REAL, intent(inout):: ds_ns(:) ! (knon) + ! "delta salinity near surface". Salinity variation in the + ! near-surface turbulent layer. That is subskin salinity minus + ! foundation salinity. In ppt. + + REAL, intent(inout):: dt_ns(:) ! (knon) + ! "delta temperature near surface". Temperature variation in the + ! near-surface turbulent layer. That is subskin temperature + ! minus foundation temperature. (Can be negative.) In K. + + REAL, intent(inout):: dter(:) ! (knon) + ! Temperature variation in the diffusive microlayer, that is + ! ocean-air interface temperature minus subskin temperature. In + ! K. + + REAL, intent(inout):: dser(:) ! (knon) + ! Salinity variation in the diffusive microlayer, that is + ! ocean-air interface salinity minus subskin salinity. In ppt. + + real, intent(inout):: dt_ds(:) ! (knon) + ! (tks / tkt) * dTer, in K + +!GG + REAL, DIMENSION(klon), INTENT(IN) :: dthetadz300 + REAL, DIMENSION(klon), INTENT(OUT) :: Ampl +! + + ! Output variables + !************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: z0m + !albedo SB >>> + ! REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new ! new albedo in visible SW interval + ! REAL, DIMENSION(klon), INTENT(OUT) :: alb2_new ! new albedo in near IR interval + REAL, DIMENSION(6), INTENT(IN) :: SFRWL + REAL, DIMENSION(klon,nsw), INTENT(OUT) :: alb_dir_new,alb_dif_new + !albedo SB <<< + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new ! sea surface temperature, in K + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: lmt_bils + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + + REAL, intent(out):: tkt(:) ! (knon) + ! �paisseur (m) de la couche de diffusion thermique (microlayer) + ! cool skin thickness + + REAL, intent(out):: tks(:) ! (knon) + ! �paisseur (m) de la couche de diffusion de masse (microlayer) + + REAL, intent(out):: taur(:) ! (knon) + ! momentum flux due to rain, in Pa + + real, intent(out):: sss(:) ! (klon) + ! Bulk salinity of the surface layer of the ocean, in ppt. (Only + ! defined for subscripts 1:knon, but we have to declare it with + ! size klon because of the coupling machinery.) + +#ifdef ISO + REAL, DIMENSION(ntraciso,klon), INTENT(out) :: xtevap ! isotopes in surface evaporation flux + REAL, DIMENSION(klon), INTENT(out) :: h1 ! just a diagnostic, not useful for the simulation +#endif + + ! Local variables + !************************************************************************* + INTEGER :: i, k + REAL :: tmp + REAL, PARAMETER :: cepdu2=(0.1)**2 + REAL, DIMENSION(klon) :: alb_eau, z0_lim + REAL, DIMENSION(klon) :: radsol + REAL, DIMENSION(klon) :: cdragq ! Cdrag pour l'evaporation + REAL, DIMENSION(klon) :: precip_totsnow + CHARACTER(len=20),PARAMETER :: modname="surf_ocean" + REAL rhoa(knon) ! density of moist air (kg / m3) + REAL sens_prec_liq(knon) + + REAL t_int(knon) ! ocean-air interface temperature, in K + REAL s_int(knon) ! ocean-air interface salinity, in ppt + + !************************************************************************** + +#ifdef ISO +#ifdef ISOVERIF + DO i = 1, knon + IF (iso_eau > 0) THEN + CALL iso_verif_egalite_choix(xtspechum(iso_eau,i), & + & spechum(i),'surf_ocean_mod 117', & + & errmax,errmaxrel) + CALL iso_verif_egalite_choix(xtsnow(iso_eau,i), & + & snow(i),'surf_ocean_mod 127', & + & errmax,errmaxrel) + ENDIF !IF (iso_eau > 0) then + ENDDO !DO i=1,klon +#endif +#endif + + !****************************************************************************** + ! Calculate total net radiance at surface + ! + !****************************************************************************** + radsol(1:klon) = 0.0 ! initialisation a priori inutile + radsol(1:knon) = swnet(1:knon) + lwnet(1:knon) + + + !**************************************************************************************** + !Total solid precip + + IF (ok_bs) THEN + precip_totsnow(:)=precip_snow(:)+precip_bs(:) + ELSE + precip_totsnow(:)=precip_snow(:) + ENDIF + + + !****************************************************************************** + ! Cdragq computed from cdrag + ! The difference comes only from a factor (f_z0qh_oce) on z0, so that + ! it can be computed inside surf_ocean + ! More complicated appraches may require the propagation through + ! pbl_surface of an independant cdragq variable. + !****************************************************************************** + + IF ( f_z0qh_oce .ne. 1.) THEN + ! Si on suit les formulations par exemple de Tessel, on + ! a z0h=0.4*nu/u*, z0q=0.62*nu/u*, d'ou f_z0qh_oce=0.62/0.4=1.55 + cdragq(1:knon)=cdragh(1:knon)* & + log(z1lay(1:knon)/z0h(1:knon))/log(z1lay(1:knon)/(f_z0qh_oce*z0h(1:knon))) + ELSE + cdragq(1:knon)=cdragh(1:knon) + ENDIF + + rhoa = PS(:KNON) / (Rd * temp_air(:knon) * (1. + retv * spechum(:knon))) + !****************************************************************************** + ! Switch according to type of ocean (couple, slab or forced) + !****************************************************************************** + SELECT CASE(type_ocean) + CASE('couple') + CALL ocean_cpl_noice( & + swnet, lwnet, alb1, & + windsp, fder, & + itime, dtime, knon, knindex, & + p1lay, cdragh, cdragq, cdragm, precip_rain, precip_totsnow,temp_air,spechum,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, gustiness, tsurf_in, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l, sens_prec_liq, sss, delta_sal, rhoa, & + delta_sst, dTer, dSer, dt_ds) + + CASE('slab') + CALL ocean_slab_noice( & + itime, dtime, jour, knon, knindex, & + p1lay, cdragh, cdragq, cdragm, precip_rain, precip_totsnow, temp_air, spechum,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, gustiness, tsurf_in, & + radsol, snow, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l, lmt_bils) + + CASE('force') + CALL ocean_forced_noice( & + itime, dtime, jour, knon, knindex, & + p1lay, cdragh, cdragq, cdragm, precip_rain, precip_totsnow, & + temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, gustiness, tsurf_in, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & +!GG tsurf_new, dflux_s, dflux_l, sens_prec_liq, rhoa) + tsurf_new, dflux_s, dflux_l, sens_prec_liq, rhoa, & + dthetadz300, pctsrf, Ampl & +!GG +#ifdef ISO + ,xtprecip_rain, xtprecip_snow, xtspechum,Roce,rlat, & + xtsnow,xtevap,h1 & +#endif + ) + END SELECT + + !****************************************************************************** + ! fcodron: compute lmt_bils forced case (same as wfbils_oce / 1.-contfracatm) + !****************************************************************************** + IF (type_ocean.NE.'slab') THEN + lmt_bils(1:klon)=0. + DO i=1,knon + lmt_bils(knindex(i))=(swnet(i)+lwnet(i)+fluxsens(i)+fluxlat(i)) & + *pctsrf(knindex(i),is_oce)/(1.-zmasq(knindex(i))) + END DO + END IF + + !****************************************************************************** + ! Calculate ocean surface albedo + !****************************************************************************** + !albedo SB >>> + IF (iflag_albedo==0) THEN + !--old parametrizations of ocean surface albedo + ! + IF (iflag_cycle_diurne.GE.1) THEN + ! + CALL alboc_cd(rmu0,alb_eau) + ! + !--ad-hoc correction for model radiative balance tuning + !--now outside alboc_cd routine + alb_eau(1:klon) = fmagic*alb_eau(1:klon) + pmagic + alb_eau(1:klon)=MIN(MAX(alb_eau(1:klon),0.0),1.0) + ! + ELSE + ! + CALL alboc(REAL(jour),rlat,alb_eau) + !--ad-hoc correction for model radiative balance tuning + !--now outside alboc routine + alb_eau(1:klon) = fmagic*alb_eau(1:klon) + pmagic + alb_eau(1:klon)=MIN(MAX(alb_eau(1:klon),0.04),0.60) + ! + ENDIF + ! + DO i =1, knon + DO k=1,nsw + alb_dir_new(i,k) = alb_eau(knindex(i)) + ENDDO + ENDDO + !IM 09122015 next line corresponds to the old way of doing in LMDZ5A/IPSLCM5A versions + !albedo for diffuse radiation is taken the same as for direct radiation + alb_dif_new(1:knon,:)=alb_dir_new(1:knon,:) + !IM 09122015 end + ! + ELSE IF (iflag_albedo==1) THEN + !--new parametrization of ocean surface albedo by Sunghye Baek + !--albedo for direct and diffuse radiation are different + ! + CALL ocean_albedo(knon,rmu0,knindex,windsp,SFRWL,alb_dir_new,alb_dif_new) + ! + !--ad-hoc correction for model radiative balance tuning + alb_dir_new(1:knon,:) = fmagic*alb_dir_new(1:knon,:) + pmagic + alb_dif_new(1:knon,:) = fmagic*alb_dif_new(1:knon,:) + pmagic + alb_dir_new(1:knon,:)=MIN(MAX(alb_dir_new(1:knon,:),0.0),1.0) + alb_dif_new(1:knon,:)=MIN(MAX(alb_dif_new(1:knon,:),0.0),1.0) + ! + ELSE IF (iflag_albedo==2) THEN + ! F. Codron albedo read from limit.nc + CALL limit_read_rug_alb(itime, dtime, jour,& + knon, knindex, z0_lim, alb_eau) + DO i =1, knon + DO k=1,nsw + alb_dir_new(i,k) = alb_eau(i) + ENDDO + ENDDO + alb_dif_new=alb_dir_new + ENDIF + !albedo SB <<< + + !****************************************************************************** + ! Calculate the rugosity + !****************************************************************************** + IF (iflag_z0_oce==0) THEN + DO i = 1, knon + tmp = MAX(cepdu2,gustiness(i)+u1(i)**2+v1(i)**2) + z0m(i) = 0.018*cdragm(i) * (gustiness(i)+u1(i)**2+v1(i)**2)/RG & + + 0.11*14e-6 / SQRT(cdragm(i) * tmp) + z0m(i) = MAX(1.5e-05,z0m(i)) + ENDDO + z0h(1:knon)=z0m(1:knon) ! En attendant mieux + + ELSE IF (iflag_z0_oce==1) THEN + DO i = 1, knon + tmp = MAX(cepdu2,gustiness(i)+u1(i)**2+v1(i)**2) + z0m(i) = 0.018*cdragm(i) * (gustiness(i)+u1(i)**2+v1(i)**2)/RG & + + 0.11*14e-6 / SQRT(cdragm(i) * tmp) + z0m(i) = MAX(1.5e-05,z0m(i)) + z0h(i)=0.4*14e-6 / SQRT(cdragm(i) * tmp) + ENDDO + ELSE IF (iflag_z0_oce==-1) THEN + DO i = 1, knon + z0m(i) = z0min + z0h(i) = z0min + ENDDO + ELSE + CALL abort_physic(modname,'version non prevue',1) + ENDIF + + if (activate_ocean_skin >= 1) then + if (type_ocean /= 'couple') sss(:knon) = 35. + call bulk_flux(tkt, tks, taur, dter, dser, t_int, s_int, ds_ns, dt_ns, & + u = windsp(:knon), t_ocean_1 = tsurf_new(:knon), s1 = sss(:knon), & + rain = precip_rain(:knon) + precip_totsnow(:knon), & + hf = - fluxsens(:knon), hlb = - fluxlat(:knon), & + rnl = - lwnet(:knon), & + tau = sqrt(flux_u1(:knon)**2 + flux_v1(:knon)**2), rhoa = rhoa, & + xlv = [(rlvtt, i = 1, knon)], rf = - sens_prec_liq, dtime = dtime, & + rns = swnet(:knon)) + delta_sst = t_int - tsurf_new(:knon) + delta_sal = s_int - sss(:knon) + + if (activate_ocean_skin == 2) then + tsurf_new(:knon) = t_int + if (type_ocean == 'couple') dt_ds = (tks / tkt) * dter + end if + end if + + END SUBROUTINE surf_ocean + !**************************************************************************** + ! +END MODULE surf_ocean_mod Index: LMDZ6/trunk/libf/phylmdiso/surf_param_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/surf_param_mod.F90 (revision 5943) +++ LMDZ6/trunk/libf/phylmdiso/surf_param_mod.F90 (revision 5943) @@ -0,0 +1,168 @@ +MODULE surf_param_mod +! + IMPLICIT NONE +! +CONTAINS +! +!------------------------------------------------------------------------------- +! +FUNCTION eff_surf_param(klon, nbtersurf, x, frac, hatype, Zref) RESULT(eff_param) +! +!------------------------------------------------------------------------------- +! +! Arguments: + INTEGER, INTENT(IN) :: klon ! grid point + INTEGER, INTENT(IN) :: nbtersurf ! number of land hetero. subsurfaces + REAL, DIMENSION(klon, nbtersurf), INTENT(IN) :: x ! variable or parameter to integrate + REAL, DIMENSION(klon, nbtersurf), INTENT(IN) :: frac ! fraction of each land hetero. subsurface + CHARACTER(LEN=3), INTENT(IN) :: hatype ! method to integrate the parameter + REAL, OPTIONAL, DIMENSION(klon), INTENT(IN) :: Zref ! reference height for CDN averaging (m) + REAL, DIMENSION(klon) :: eff_param ! effective parameter +!------------------------------------------------------------------------------- +! Local variables: + INTEGER ik, is + REAL :: zrefd = 10. ! default reference height for CDN averaging (m) + REAL :: Cdref ! reference height for CDN averaging (m) +!------------------------------------------------------------------------------- +! + eff_param(:) = 0. + DO ik = 1, klon + DO is = 1, nbtersurf + ! + ! arithmetic averaging + IF (hatype == 'ARI') THEN + eff_param(ik) = eff_param(ik) + frac(ik,is) * x(ik,is) + ! + ! inverse averaging + ELSEIF (hatype == 'INV') THEN + IF (x(ik,is) .NE. 0.) THEN + eff_param(ik) = eff_param(ik) + frac(ik,is) * 1./x(ik,is) + ENDIF + ! + ! inverse of square logarithm averaging + ELSEIF (hatype == 'CDN') THEN + IF (PRESENT(Zref)) THEN + Cdref = Zref(ik) + ELSE + Cdref = zrefd + ENDIF + ! + IF (x(ik,is) .NE. 0.) THEN + eff_param(ik) = eff_param(ik) + frac(ik,is) * 1./(LOG(Cdref/x(ik,is)))**2 + ENDIF + ! + ELSE + PRINT*, 'eff_surf_param: invalid averaging type: ', hatype + ENDIF + ENDDO + ! + IF (hatype == 'CDN') THEN + eff_param(ik) = Cdref * exp(-sqrt(1./eff_param(ik))) + ENDIF + ! + ENDDO +! +END FUNCTION eff_surf_param +! +! +!------------------------------------------------------------------------------- +! +FUNCTION average_surf_var(klon, nbtersurf, x, frac, hatype) RESULT(x_avg) +! +!------------------------------------------------------------------------------- +! +! Arguments: + INTEGER, INTENT(IN) :: klon ! grid point + INTEGER, INTENT(IN) :: nbtersurf ! number of land hetero. subsurfaces + REAL, DIMENSION(klon, nbtersurf), INTENT(IN) :: x ! variable or parameter to integrate + REAL, DIMENSION(klon, nbtersurf), INTENT(IN) :: frac ! fraction of each land hetero. subsurface + CHARACTER(LEN=3), INTENT(IN) :: hatype ! method to integrate the parameter + REAL, DIMENSION(klon) :: x_avg ! average variable +! +! Local variables: + INTEGER ik, is +! +!------------------------------------------------------------------------------- +! + x_avg(:) = 0. + DO ik = 1, klon + DO is = 1, nbtersurf + ! + ! arithmetic averaging + IF (hatype == 'ARI') THEN + x_avg(ik) = x_avg(ik) + frac(ik,is) * x(ik,is) + ELSE + PRINT*, 'average_surf_var: invalid averaging type: ', hatype + ENDIF + ENDDO + ENDDO +! +END FUNCTION average_surf_var +! +!------------------------------------------------------------------------------- +! +FUNCTION interpol_tsoil(klon, nbtersurf, nsoilmx, nbtsoildepths, alpha, period, inertie, hcond, tsoil_depth, tsurf, tsoil_) RESULT(tsoil) +! +!------------------------------------------------------------------------------- +! +! Arguments: + INTEGER, INTENT(IN) :: klon ! grid point + INTEGER, INTENT(IN) :: nbtersurf ! number of land hetero. subsurfaces + INTEGER, INTENT(IN) :: nsoilmx ! number of soil layers in the model grid + INTEGER, INTENT(IN) :: nbtsoildepths ! number of soil depths for soil temperature initialization + REAL, INTENT(IN) :: alpha ! parameter for soil discretization + REAL, INTENT(IN) :: period ! parameter for soil discretization + REAL, DIMENSION(klon, nbtersurf), INTENT(IN) :: inertie ! soil thermal inertia + REAL, DIMENSION(klon, nbtersurf), INTENT(IN) :: hcond ! soil heat conductivity + REAL, DIMENSION(klon, nbtsoildepths, nbtersurf), INTENT(IN) :: tsoil_depth ! soil depth at which temperature is given (m) + REAL, DIMENSION(klon, nbtersurf), INTENT(IN) :: tsurf ! surface temperature + REAL, DIMENSION(klon, nbtsoildepths, nbtersurf), INTENT(IN) :: tsoil_ ! soil temperature given at tsoil_depths + REAL, DIMENSION(klon, nsoilmx, nbtersurf) :: tsoil ! soil temperature interpolated in the model grid +! +! Local variables: + INTEGER ik, is, iq, it + REAL pi, slope, inter + REAL, DIMENSION(klon, nbtersurf) :: z1, hcap ! first layer depth and soil heat capacity + REAL, DIMENSION(klon, nsoilmx, nbtersurf) :: z ! depth of the middle of the soil layer in the model grid (m) +! +!------------------------------------------------------------------------------- +! + pi = ACOS(-1.) + ! + DO ik = 1, klon + DO is = 1, nbtersurf + ! + hcap(ik,is) = inertie(ik,is)*inertie(ik,is)/hcond(ik,is) + z1(ik,is) = SQRT(period*hcond(ik,is)/(pi*hcap(ik,is))) + ! + DO iq = 1, nsoilmx + ! compute depth of middle soil layer (in m) + z(ik,iq,is) = z1(ik,is) * (alpha**(iq-0.5) - 1.) / (alpha - 1.) + ! if z is between the surface and first tsoil_depth + IF ((z(ik,iq,is) .GT. 0.) .AND. (z(ik,iq,is) .LE. tsoil_depth(ik,1,is))) THEN + slope = (tsoil_(ik,1,is) - tsurf(ik,is)) / (tsoil_depth(ik,1,is) - 0.) + inter = tsurf(ik,is) + tsoil(ik,iq,is) = slope * z(ik,iq,is) + inter + ENDIF + ! other levels + DO it = 1, nbtsoildepths-1 + IF ((z(ik,iq,is) .GT. tsoil_depth(ik,it,is)) .AND. (z(ik,iq,is) .LE. tsoil_depth(ik,it+1,is))) THEN + slope = (tsoil_(ik,it+1,is) - tsoil_(ik,it,is)) / (tsoil_depth(ik,it+1,is) - tsoil_depth(ik,it,is)) + inter = tsoil_(ik,it,is) - slope * tsoil_depth(ik,it,is) + tsoil(ik,iq,is) = slope * z(ik,iq,is) + inter + ENDIF + ENDDO + ! for layers below + IF (z(ik,iq,is) .GT. tsoil_depth(ik,nbtsoildepths,is)) THEN + tsoil(ik,iq,is) = tsoil_(ik,nbtsoildepths,is) + ENDIF + ENDDO + ! + ENDDO + ENDDO +! +END FUNCTION interpol_tsoil +! +!------------------------------------------------------------------------------- +! +END MODULE surf_param_mod Index: LMDZ6/trunk/libf/phylmdiso/surf_seaice_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/surf_seaice_mod.F90 (revision 5943) +++ LMDZ6/trunk/libf/phylmdiso/surf_seaice_mod.F90 (revision 5943) @@ -0,0 +1,235 @@ +! +! $Id: surf_seaice_mod.F90 5662 2025-05-20 14:24:41Z fairhead $ +! +MODULE surf_seaice_mod + + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_seaice( & + rlon, rlat, swnet, lwnet, alb1, fder, & + itime, dtime, jour, knon, knindex, & + lafin, & + tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, gustiness, pctsrf, & + snow, qsurf, qsol, agesno, tsoil, & + z0m, z0h, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, & + tsurf_new, dflux_s, dflux_l, & +!GG flux_u1, flux_v1) + flux_u1, flux_v1, hice, tice,bilg_cumul, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic & +!GG +#ifdef ISO + & ,xtprecip_rain, xtprecip_snow,xtspechum,Roce, & + & xtsnow,xtsol,xtevap,Rland_ice & +#endif + & ) + + USE dimphy + USE surface_data + USE ocean_forced_mod, ONLY : ocean_forced_ice + USE ocean_cpl_mod, ONLY : ocean_cpl_ice + USE ocean_slab_mod, ONLY : ocean_slab_ice + USE indice_sol_mod +#ifdef ISO + USE infotrac_phy, ONLY : ntiso,niso +#endif + USE clesphys_mod_h + USE yomcst_mod_h +USE dimsoil_mod_h, ONLY: nsoilmx + +! +! This subroutine will make a call to ocean_XXX_ice according to the ocean mode (force, +! slab or couple). The calculation of rugosity for the sea-ice surface is also done +! in here because it is the same calculation for the different modes of ocean. +! + + + ! for rd and retv + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: lafin + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: swnet ! net shortwave radiation at surface + REAL, DIMENSION(klon), INTENT(IN) :: lwnet ! net longwave radiation at surface + REAL, DIMENSION(klon), INTENT(IN) :: alb1 ! albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(IN) :: fder + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, gustiness + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf +#ifdef ISO + REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtprecip_rain, xtprecip_snow + REAL, DIMENSION(klon), INTENT(IN) :: xtspechum + REAL, DIMENSION(niso,klon), INTENT(IN) :: Roce + REAL, DIMENSION(niso,klon), INTENT(IN) :: Rland_ice +#endif + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsurf, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil +#ifdef ISO + REAL, DIMENSION(niso,klon), INTENT(INOUT) :: xtsnow + REAL, DIMENSION(niso,klon), INTENT(IN) :: xtsol +#endif + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: z0m, z0h +!albedo SB >>> +! REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new ! new albedo in visible SW interval +! REAL, DIMENSION(klon), INTENT(OUT) :: alb2_new ! new albedo in near IR interval + REAL, DIMENSION(6), INTENT(IN) :: SFRWL + REAL, DIMENSION(klon,nsw), INTENT(OUT) :: alb_dir_new,alb_dif_new +!albedo SB <<< + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 +!GG + REAL, DIMENSION(klon), INTENT(INOUT) :: hice, tice, bilg_cumul + REAL, DIMENSION(klon), INTENT(INOUT) :: fcds,fcdi, dh_basal_growth,dh_basal_melt + REAL, DIMENSION(klon), INTENT(INOUT) :: dh_top_melt, dh_snow2sic, dtice_melt, dtice_snow2sic +!GG +#ifdef ISO + REAL, DIMENSION(ntiso,klon), INTENT(OUT) :: xtevap +#endif + +! Local arguments +!**************************************************************************************** + REAL, DIMENSION(klon) :: radsol +#ifdef ISO +#ifdef ISOVERIF + INTEGER :: j +#endif +#endif + +!albedo SB >>> + REAL, DIMENSION(klon) :: alb1_new,alb2_new +!albedo SB <<< + + real rhoa(knon) ! density of moist air (kg / m3) + +! End definitions +!**************************************************************************************** + + +!**************************************************************************************** +! Calculate total net radiance at surface +! +!**************************************************************************************** + radsol(:) = 0.0 + radsol(1:knon) = swnet(1:knon) + lwnet(1:knon) + + rhoa = PS(:KNON) / (Rd * temp_air(:knon) * (1. + retv * spechum(:knon))) + +!**************************************************************************************** +! Switch according to type of ocean (couple, slab or forced) +! +!**************************************************************************************** + IF (type_ocean == 'couple') THEN + + CALL ocean_cpl_ice( & + rlon, rlat, swnet, lwnet, alb1, & + fder, & + itime, dtime, knon, knindex, & + lafin,& + p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, gustiness, pctsrf, & + radsol, snow, qsurf, & + alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l, rhoa) + + ELSE IF (type_ocean == 'slab'.AND.version_ocean=='sicINT') THEN + CALL ocean_slab_ice( & + itime, dtime, jour, knon, knindex, & + tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, gustiness, & + radsol, snow, qsurf, qsol, agesno, & + alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l, swnet) + + ELSE ! type_ocean=force or slab +sicOBS or sicNO + CALL ocean_forced_ice( & + itime, dtime, jour, knon, knindex, & + tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & +!GG ps, u1, v1, gustiness, & + ps, u1, v1, gustiness,pctsrf, & +!GG + radsol, snow, qsol, agesno, tsoil, & + qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & +!GG tsurf_new, dflux_s, dflux_l, rhoa) + tsurf_new, dflux_s, dflux_l,rhoa,swnet,hice, tice, bilg_cumul, & + fcds, fcdi, dh_basal_growth, dh_basal_melt, dh_top_melt, dh_snow2sic, & + dtice_melt, dtice_snow2sic & +!GG +#ifdef ISO + ,xtprecip_rain, xtprecip_snow, xtspechum,Roce, & + xtsnow, xtsol,xtevap,Rland_ice & +#endif + ) + + END IF + +!**************************************************************************************** +! Calculate rugosity +! +!**************************************************************************************** + + z0m=z0m_seaice + z0h = z0h_seaice + +!albedo SB >>> + select case(NSW) + case(2) + alb_dir_new(1:knon,1)=alb1_new(1:knon) + alb_dir_new(1:knon,2)=alb2_new(1:knon) + case(4) + alb_dir_new(1:knon,1)=alb1_new(1:knon) + alb_dir_new(1:knon,2)=alb2_new(1:knon) + alb_dir_new(1:knon,3)=alb2_new(1:knon) + alb_dir_new(1:knon,4)=alb2_new(1:knon) + case(6) + alb_dir_new(1:knon,1)=alb1_new(1:knon) + alb_dir_new(1:knon,2)=alb1_new(1:knon) + alb_dir_new(1:knon,3)=alb1_new(1:knon) + alb_dir_new(1:knon,4)=alb2_new(1:knon) + alb_dir_new(1:knon,5)=alb2_new(1:knon) + alb_dir_new(1:knon,6)=alb2_new(1:knon) + end select +alb_dif_new=alb_dir_new +!albedo SB <<< + + + + + END SUBROUTINE surf_seaice +! +!**************************************************************************************** +! +END MODULE surf_seaice_mod + Index: LMDZ6/trunk/libf/phylmdiso/yamada_c.F90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/yamada_c.F90 (revision 5943) +++ LMDZ6/trunk/libf/phylmdiso/yamada_c.F90 (revision 5943) @@ -0,0 +1,481 @@ +! +! $Header$ +! + SUBROUTINE yamada_c(ngrid,timestep,plev,play & + & ,pu,pv,pt,d_u,d_v,d_t,cd,q2,km,kn,kq,d_t_diss,ustar & + & ,iflag_pbl) + USE dimphy, ONLY: klon, klev + USE print_control_mod, ONLY: prt_level + USE ioipsl_getin_p_mod, ONLY : getin_p + + USE yomcst_mod_h +IMPLICIT NONE + +! +! timestep : pas de temps +! g : g +! zlev : altitude a chaque niveau (interface inferieure de la couche +! de meme indice) +! zlay : altitude au centre de chaque couche +! u,v : vitesse au centre de chaque couche +! (en entree : la valeur au debut du pas de temps) +! teta : temperature potentielle au centre de chaque couche +! (en entree : la valeur au debut du pas de temps) +! cd : cdrag +! (en entree : la valeur au debut du pas de temps) +! q2 : $q^2$ au bas de chaque couche +! (en entree : la valeur au debut du pas de temps) +! (en sortie : la valeur a la fin du pas de temps) +! km : diffusivite turbulente de quantite de mouvement (au bas de chaque +! couche) +! (en sortie : la valeur a la fin du pas de temps) +! kn : diffusivite turbulente des scalaires (au bas de chaque couche) +! (en sortie : la valeur a la fin du pas de temps) +! +! iflag_pbl doit valoir entre 6 et 9 +! l=6, on prend systematiquement une longueur d'equilibre +! iflag_pbl=6 : MY 2.0 +! iflag_pbl=7 : MY 2.0.Fournier +! iflag_pbl=8/9 : MY 2.5 +! iflag_pbl=8 with special obsolete treatments for convergence +! with Cmpi5 NPv3.1 simulations +! iflag_pbl=10/11 : New scheme M2 and N2 explicit and dissiptation exact +! iflag_pbl=12 = 11 with vertical diffusion off q2 +! +! 2013/04/01 (FH hourdin@lmd.jussieu.fr) +! Correction for very stable PBLs (iflag_pbl=10 and 11) +! iflag_pbl=8 converges numerically with NPv3.1 +! iflag_pbl=11 -> the model starts with NP from start files created by ce0l +! -> the model can run with longer time-steps. +!....................................................................... + + REAL, DIMENSION(klon,klev) :: d_u,d_v,d_t + REAL, DIMENSION(klon,klev) :: pu,pv,pt + REAL, DIMENSION(klon,klev) :: d_t_diss + + REAL timestep + real plev(klon,klev+1) + real play(klon,klev) + real ustar(klon) + real kmin,qmin,pblhmin(klon),coriol(klon) + REAL zlev(klon,klev+1) + REAL zlay(klon,klev) + REAL zu(klon,klev) + REAL zv(klon,klev) + REAL zt(klon,klev) + REAL teta(klon,klev) + REAL cd(klon) + REAL q2(klon,klev+1),qpre + REAL unsdz(klon,klev) + REAL unsdzdec(klon,klev+1) + + REAL km(klon,klev) + REAL kmpre(klon,klev+1),tmp2 + REAL mpre(klon,klev+1) + REAL kn(klon,klev) + REAL kq(klon,klev) + real ff(klon,klev+1),delta(klon,klev+1) + real aa(klon,klev+1),aa0,aa1 + integer iflag_pbl,ngrid + integer nlay,nlev + + logical first + integer ipas + save first,ipas +!FH/IM data first,ipas/.true.,0/ + data first,ipas/.false.,0/ +!$OMP THREADPRIVATE( first,ipas) + INTEGER, SAVE :: iflag_tke_diff=0 +!$OMP THREADPRIVATE(iflag_tke_diff) + + + integer ig,k + + + real ri,zrif,zalpha,zsm,zsn + real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev) + + real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1) + REAL, DIMENSION(klon,klev+1) :: km2,kn2,sqrtq + real dtetadz(klon,klev+1) + real m2cstat,mcstat,kmcstat + real l(klon,klev+1) + real leff(klon,klev+1) + real,allocatable,save :: l0(:) +!$OMP THREADPRIVATE(l0) + real sq(klon),sqz(klon),zz(klon,klev+1) + integer iter + + real ric,rifc,b1,kap + save ric,rifc,b1,kap + data ric,rifc,b1,kap/0.195,0.191,16.6,0.4/ +!$OMP THREADPRIVATE(ric,rifc,b1,kap) + real frif,falpha,fsm + real fl,zzz,zl0,zq2,zn2 + + real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev) + real lyam(klon,klev),knyam(klon,klev) + real w2yam(klon,klev),t2yam(klon,klev) + logical,save :: firstcall=.true. +!$OMP THREADPRIVATE(firstcall) + CHARACTER(len=20),PARAMETER :: modname="yamada_c" +REAL, DIMENSION(klon,klev+1) :: fluxu,fluxv,fluxt +REAL, DIMENSION(klon,klev+1) :: dddu,dddv,dddt +REAL, DIMENSION(klon,klev) :: exner,masse +REAL, DIMENSION(klon,klev+1) :: masseb,q2old,q2neg + LOGICAL okiophys + + frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156)) + falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri) + fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri)) + fl(zzz,zl0,zq2,zn2)= & + & max(min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) & + & ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) ,1.) + + + okiophys=klon==1 + if (firstcall) then + CALL getin_p('iflag_tke_diff',iflag_tke_diff) + allocate(l0(klon)) + firstcall=.false. + endif + + IF (ngrid<=0) RETURN ! Bizarre : on n a pas ce probeleme pour coef_diff_turb + + nlay=klev + nlev=klev+1 + + +!------------------------------------------------------------------------- +! Computation of conservative source terms from the turbulent tendencies +!------------------------------------------------------------------------- + + + zalpha=0.5 ! Anciennement 0.5. Essayer de voir pourquoi ? + zu(:,:)=pu(:,:)+zalpha*d_u(:,:) + zv(:,:)=pv(:,:)+zalpha*d_v(:,:) + zt(:,:)=pt(:,:)+zalpha*d_t(:,:) + + do k=1,klev + exner(:,k)=(play(:,k)/plev(:,1))**RKAPPA + masse(:,k)=(plev(:,k)-plev(:,k+1))/RG + teta(:,k)=zt(:,k)/exner(:,k) + enddo + +! Atmospheric mass at layer interfaces, where the TKE is computed + masseb(:,:)=0. + do k=1,klev + masseb(:,k)=masseb(:,k)+masse(:,k) + masseb(:,k+1)=masseb(:,k+1)+masse(:,k) + enddo + masseb(:,:)=0.5*masseb(:,:) + + zlev(:,1)=0. + zlay(:,1)=RCPD*teta(:,1)*(1.-exner(:,1)) + do k=1,klev-1 + zlay(:,k+1)=zlay(:,k)+0.5*RCPD*(teta(:,k)+teta(:,k+1))*(exner(:,k)-exner(:,k+1))/RG + zlev(:,k)=0.5*(zlay(:,k)+zlay(:,k+1)) ! PASBO + enddo + + fluxu(:,klev+1)=0. + fluxv(:,klev+1)=0. + fluxt(:,klev+1)=0. + + do k=klev,1,-1 + fluxu(:,k)=fluxu(:,k+1)+masse(:,k)*d_u(:,k) + fluxv(:,k)=fluxv(:,k+1)+masse(:,k)*d_v(:,k) + fluxt(:,k)=fluxt(:,k+1)+masse(:,k)*d_t(:,k)/exner(:,k) ! Flux de theta + enddo + + dddu(:,1)=2*zu(:,1)*fluxu(:,1) + dddv(:,1)=2*zv(:,1)*fluxv(:,1) + dddt(:,1)=(exner(:,1)-1.)*fluxt(:,1) + + do k=2,klev + dddu(:,k)=(zu(:,k)-zu(:,k-1))*fluxu(:,k) + dddv(:,k)=(zv(:,k)-zv(:,k-1))*fluxv(:,k) + dddt(:,k)=(exner(:,k)-exner(:,k-1))*fluxt(:,k) + enddo + dddu(:,klev+1)=0. + dddv(:,klev+1)=0. + dddt(:,klev+1)=0. + +#ifdef IOPHYS +if (okiophys) then + call iophys_ecrit('zlay',klev,'Geop','m',zlay) + call iophys_ecrit('teta',klev,'teta','K',teta) + call iophys_ecrit('temp',klev,'temp','K',zt) + call iophys_ecrit('pt',klev,'temp','K',pt) + call iophys_ecrit('pu',klev,'u','m/s',pu) + call iophys_ecrit('pv',klev,'v','m/s',pv) + call iophys_ecrit('d_u',klev,'d_u','m/s2',d_u) + call iophys_ecrit('d_v',klev,'d_v','m/s2',d_v) + call iophys_ecrit('d_t',klev,'d_t','K/s',d_t) + call iophys_ecrit('exner',klev,'exner','',exner) + call iophys_ecrit('masse',klev,'masse','',masse) + call iophys_ecrit('masseb',klev,'masseb','',masseb) +endif +#endif + + + + ipas=ipas+1 + + +!....................................................................... +! les increments verticaux +!....................................................................... +! +!!!!!! allerte !!!!!c +!!!!!! zlev n'est pas declare a nlev !!!!!c +!!!!!! ----> + DO ig=1,ngrid + zlev(ig,nlev)=zlay(ig,nlay) & + & +( zlay(ig,nlay) - zlev(ig,nlev-1) ) + ENDDO +!!!!!! <---- +!!!!!! allerte !!!!!c +! + DO k=1,nlay + DO ig=1,ngrid + unsdz(ig,k)=1.E+0/(zlev(ig,k+1)-zlev(ig,k)) + ENDDO + ENDDO + DO ig=1,ngrid + unsdzdec(ig,1)=1.E+0/(zlay(ig,1)-zlev(ig,1)) + ENDDO + DO k=2,nlay + DO ig=1,ngrid + unsdzdec(ig,k)=1.E+0/(zlay(ig,k)-zlay(ig,k-1)) + ENDDO + ENDDO + DO ig=1,ngrid + unsdzdec(ig,nlay+1)=1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay)) + ENDDO +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Computing M^2, N^2, Richardson numbers, stability functions +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + do k=2,klev + do ig=1,ngrid + dz(ig,k)=zlay(ig,k)-zlay(ig,k-1) + m2(ig,k)=((zu(ig,k)-zu(ig,k-1))**2+(zv(ig,k)-zv(ig,k-1))**2)/(dz(ig,k)*dz(ig,k)) + dtetadz(ig,k)=(teta(ig,k)-teta(ig,k-1))/dz(ig,k) + n2(ig,k)=RG*2.*dtetadz(ig,k)/(teta(ig,k-1)+teta(ig,k)) +! n2(ig,k)=0. + ri=n2(ig,k)/max(m2(ig,k),1.e-10) + if (ri.lt.ric) then + rif(ig,k)=frif(ri) + else + rif(ig,k)=rifc + endif + if(rif(ig,k)<0.16) then + alpha(ig,k)=falpha(rif(ig,k)) + sm(ig,k)=fsm(rif(ig,k)) + else + alpha(ig,k)=1.12 + sm(ig,k)=0.085 + endif + zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k) + enddo + enddo + + + +!==================================================================== +! Computing the mixing length +!==================================================================== + +! Mise a jour de l0 + if (iflag_pbl==8.or.iflag_pbl==10) then + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Iterative computation of l0 +! This version is kept for iflag_pbl only for convergence +! with NPv3.1 Cmip5 simulations +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do ig=1,ngrid + sq(ig)=1.e-10 + sqz(ig)=1.e-10 + enddo + do k=2,klev-1 + do ig=1,ngrid + zq=sqrt(q2(ig,k)) + sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1)) + sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1)) + enddo + enddo + do ig=1,ngrid + l0(ig)=0.2*sqz(ig)/sq(ig) + enddo + do k=2,klev + do ig=1,ngrid + l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k)) + enddo + enddo +! print*,'L0 cas 8 ou 10 ',l0 + + else + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! In all other case, the assymptotic mixing length l0 is imposed (100m) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + l0(:)=150. + do k=2,klev + do ig=1,ngrid + l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k)) + enddo + enddo +! print*,'L0 cas autres ',l0 + + endif + + +#ifdef IOPHYS +if (okiophys) then +call iophys_ecrit('rif',klev,'Flux Richardson','m',rif(:,1:klev)) +call iophys_ecrit('m2',klev,'m2 ','m/s',m2(:,1:klev)) +call iophys_ecrit('Km2app',klev,'m2 conserv','m/s',km(:,1:klev)*m2(:,1:klev)) +call iophys_ecrit('Km',klev,'Km','m2/s',km(:,1:klev)) +endif +#endif + + +IF (iflag_pbl<20) then + ! For diagnostics only + RETURN + +ELSE + +! print*,'OK1' + +! Evolution of TKE under source terms K M2 and K N2 + leff(:,:)=max(l(:,:),1.) + +!################################################################## +!# IF (iflag_pbl==29) THEN +!# STOP'Ne pas utiliser iflag_pbl=29' +!# km2(:,:)=km(:,:)*m2(:,:) +!# kn2(:,:)=kn2(:,:)*rif(:,:) +!# ELSEIF (iflag_pbl==25) THEN +! VERSION AVEC LA TKE EN MILIEU DE COUCHE +!# STOP'Ne pas utiliser iflag_pbl=25' +!# DO k=1,klev +!# km2(:,k)=-0.5*(dddu(:,k)+dddv(:,k)+dddu(:,k+1)+dddv(:,k+1)) & +!# & /(masse(:,k)*timestep) +!# kn2(:,k)=rcpd*0.5*(dddt(:,k)+dddt(:,k+1))/(masse(:,k)*timestep) +!# leff(:,k)=0.5*(leff(:,k)+leff(:,k+1)) +!# ENDDO +!# km2(:,klev+1)=0. ; kn2(:,klev+1)=0. +!# ELSE +!################################################################# + + km2(:,:)=-(dddu(:,:)+dddv(:,:))/(masseb(:,:)*timestep) + kn2(:,:)=rcpd*dddt(:,:)/(masseb(:,:)*timestep) +! ENDIF + q2neg(:,:)=q2(:,:)+timestep*(km2(:,:)-kn2(:,:)) + q2(:,:)=min(max(q2neg(:,:),1.e-10),1.e4) + + +#ifdef IOPHYS +if (okiophys) then + call iophys_ecrit('km2',klev,'m2 conserv','m/s',km2(:,1:klev)) + call iophys_ecrit('kn2',klev,'n2 conserv','m/s',kn2(:,1:klev)) +endif +#endif + +! Dissipation of TKE + q2old(:,:)=q2(:,:) + q2(:,:)=1./(1./sqrt(q2(:,:))+timestep/(2*leff(:,:)*b1)) + q2(:,:)=q2(:,:)*q2(:,:) +! IF (iflag_pbl<=24) THEN + DO k=1,klev + d_t_diss(:,k)=(masseb(:,k)*(q2neg(:,k)-q2(:,k))+masseb(:,k+1)*(q2neg(:,k+1)-q2(:,k+1)))/(2.*rcpd*masse(:,k)) + ENDDO + +!################################################################### +! ELSE IF (iflag_pbl<=27) THEN +! DO k=1,klev +! d_t_diss(:,k)=(q2neg(:,k)-q2(:,k))/rcpd +! ENDDO +! ENDIF +! print*,'iflag_pbl ',d_t_diss +!################################################################### + + +! Compuation of stability functions +! IF (iflag_pbl/=29) THEN + DO k=1,klev + DO ig=1,ngrid + IF (ABS(km2(ig,k))<=1.e-20) THEN + rif(ig,k)=0. + ELSE + rif(ig,k)=min(kn2(ig,k)/km2(ig,k),rifc) + ENDIF + IF (rif(ig,k).lt.0.16) THEN + alpha(ig,k)=falpha(rif(ig,k)) + sm(ig,k)=fsm(rif(ig,k)) + else + alpha(ig,k)=1.12 + sm(ig,k)=0.085 + endif + ENDDO + ENDDO +! ENDIF + +! Computation of turbulent diffusivities +! IF (25<=iflag_pbl.and.iflag_pbl<=28) THEN +! DO k=2,klev +! sqrtq(:,k)=sqrt(0.5*(q2(:,k)+q2(:,k-1))) +! ENDDO +! ELSE + kq(:,:)=0. + DO k=1,klev + ! Coefficient au milieu des couches pour diffuser la TKE + kq(:,k)=0.5*leff(:,k)*sqrt(q2(:,k))*0.2 + ENDDO + +#ifdef IOPHYS +if (okiophys) then +call iophys_ecrit('q2b',klev,'KTE inter','m2/s',q2(:,1:klev)) +endif +#endif + + IF (iflag_tke_diff==1) THEN + CALL vdif_q2(timestep, RG, RD, ngrid, plev, pt, kq, q2) + ENDIF + + km(:,:)=0. + kn(:,:)=0. + DO k=1,klev + km(:,k)=leff(:,k)*sqrt(q2(:,k))*sm(:,k) + kn(:,k)=km(:,k)*alpha(:,k) + ENDDO + + +#ifdef IOPHYS +if (okiophys) then +call iophys_ecrit('mixingl',klev,'Mixing length','m',leff(:,1:klev)) +call iophys_ecrit('rife',klev,'Flux Richardson','m',rif(:,1:klev)) +call iophys_ecrit('q2f',klev,'KTE finale','m2/s',q2(:,1:klev)) +call iophys_ecrit('q2neg',klev,'KTE non bornee','m2/s',q2neg(:,1:klev)) +call iophys_ecrit('alpha',klev,'alpha','',alpha(:,1:klev)) +call iophys_ecrit('sm',klev,'sm','',sm(:,1:klev)) +call iophys_ecrit('q2f',klev,'KTE finale','m2/s',q2(:,1:klev)) +call iophys_ecrit('kmf',klev,'Kz final','m2/s',km(:,1:klev)) +call iophys_ecrit('knf',klev,'Kz final','m2/s',kn(:,1:klev)) +call iophys_ecrit('kqf',klev,'Kz final','m2/s',kq(:,1:klev)) +endif +#endif + + +ENDIF + + +! print*,'OK2' + RETURN + END SUBROUTINE yamada_c