Changeset 13655
- Timestamp:
- 2020-10-21T16:15:13+02:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice
- Files:
-
- 6 added
- 24 edited
- 1 moved
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/ABL/ablmod.F90
r13295 r13655 19 19 USE sbc_oce, ONLY : ght_abl, ghw_abl, e3t_abl, e3w_abl, jpka, jpkam1, rhoa 20 20 USE sbcblk ! use rn_efac, cdn_oce 21 USE sbc blk_phy! use some physical constants for flux computation21 USE sbc_phy ! use some physical constants for flux computation 22 22 ! 23 23 USE prtctl ! Print control (prt_ctl routine) -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/ABL/sbcabl.F90
r13214 r13655 22 22 USE sbc_oce ! Surface boundary condition: ocean fields 23 23 USE sbcblk ! Surface boundary condition: bulk formulae 24 USE sbc blk_phy! Surface boundary condition: bulk formulae24 USE sbc_phy ! Surface boundary condition: bulk formulae 25 25 USE dom_oce, ONLY : tmask 26 26 ! … … 320 320 INTEGER , INTENT(in) :: kt ! ocean time step 321 321 !! 322 REAL(wp), DIMENSION(jpi,jpj) :: zssq, zcd_du, zsen, z evp322 REAL(wp), DIMENSION(jpi,jpj) :: zssq, zcd_du, zsen, zlat, zevp 323 323 #if defined key_si3 324 324 REAL(wp), DIMENSION(jpi,jpj) :: zssqi, zcd_dui, zseni, zevpi … … 344 344 & sf(jp_uoatm)%fnow(:,:,1), sf(jp_voatm)%fnow(:,:,1), & ! <<= in 345 345 & sf(jp_qsr )%fnow(:,:,1) , sf(jp_qlw )%fnow(:,:,1) , & ! <<= in 346 & tsk_m, zssq, zcd_du, zsen, z evp) ! =>> out346 & tsk_m, zssq, zcd_du, zsen, zlat, zevp ) ! =>> out 347 347 348 348 #if defined key_si3 … … 375 375 !!------------------------------------------------------------------------------------------- 376 376 377 CALL blk_oce_2( tq_abl(:,:,2,nt_n,jp_ta), & 378 & sf(jp_qsr )%fnow(:,:,1) , sf(jp_qlw )%fnow(:,:,1), & 377 CALL blk_oce_2( tq_abl(:,:,2,nt_n,jp_ta), sf(jp_qlw )%fnow(:,:,1), & 379 378 & sf(jp_prec)%fnow(:,:,1) , sf(jp_snow)%fnow(:,:,1), & 380 & tsk_m, zsen, z evp )379 & tsk_m, zsen, zlat, zevp ) 381 380 382 381 CALL abl_rst_opn( kt ) ! Open abl restart file (if necessary) -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/ICE/icesbc.F90
r13472 r13655 59 59 !! 60 60 INTEGER :: ji, jj ! dummy loop index 61 REAL(wp), DIMENSION(jpi,jpj) :: zutau_ice, zvtau_ice 61 REAL(wp), DIMENSION(jpi,jpj) :: zutau_ice, zvtau_ice 62 62 !!------------------------------------------------------------------- 63 63 ! … … 71 71 ! 72 72 SELECT CASE( ksbc ) 73 CASE( jp_usr ) ; CALL usrdef_sbc_ice_tau( kt ) ! user defined formulation 74 CASE( jp_blk ) ; CALL blk_ice_1( sf(jp_wndi)%fnow(:,:,1), sf(jp_wndj)%fnow(:,:,1), & 75 & sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), & 73 ! 74 CASE( jp_usr ) 75 CALL usrdef_sbc_ice_tau( kt ) ! user defined formulation 76 ! 77 CASE( jp_blk ) 78 CALL blk_ice_1( sf(jp_wndi)%fnow(:,:,1), sf(jp_wndj)%fnow(:,:,1), & 79 & theta_air_zt(:,:), q_air_zt(:,:), & ! #LB: known from "sbc_oce" module... 76 80 & sf(jp_slp )%fnow(:,:,1), u_ice, v_ice, tm_su , & ! inputs 77 & putaui = utau_ice, pvtaui = vtau_ice ) ! outputs 78 ! CASE( jp_abl ) utau_ice & vtau_ice are computed in ablmod 79 CASE( jp_purecpl ) ; CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) ! Coupled formulation 81 & putaui = utau_ice, pvtaui = vtau_ice ) ! outputs 82 ! CASE( jp_abl ) utau_ice & vtau_ice are computed in ablmod 83 CASE( jp_purecpl ) 84 CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) ! Coupled formulation 80 85 END SELECT 81 86 ! 82 87 IF( ln_mixcpl) THEN ! Case of a mixed Bulk/Coupled formulation 83 88 CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice ) 84 89 DO_2D( 0, 0, 0, 0 ) 85 86 90 utau_ice(ji,jj) = utau_ice(ji,jj) * xcplmask(ji,jj,0) + zutau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 91 vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 87 92 END_2D 88 93 CALL lbc_lnk_multi( 'icesbc', utau_ice, 'U', -1.0_wp, vtau_ice, 'V', -1.0_wp ) … … 93 98 END SUBROUTINE ice_sbc_tau 94 99 95 100 96 101 SUBROUTINE ice_sbc_flx( kt, ksbc ) 97 102 !!------------------------------------------------------------------- … … 108 113 !! dqns_ice = non solar heat sensistivity [W/m2] 109 114 !! qemp_oce, qemp_ice, qprec_ice, qevap_ice = sensible heat (associated with evap & precip) [W/m2] 110 !! + some fields that are not used outside this module: 115 !! + some fields that are not used outside this module: 111 116 !! qla_ice = latent heat flux over ice [W/m2] 112 117 !! dqla_ice = latent heat sensistivity [W/m2] … … 118 123 ! 119 124 INTEGER :: ji, jj, jl ! dummy loop index 120 REAL(wp) :: zmiss_val ! missing value retrieved from xios 125 REAL(wp) :: zmiss_val ! missing value retrieved from xios 121 126 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zalb, zmsk00 ! 2D workspace 122 127 !!-------------------------------------------------------------------- … … 138 143 ! 139 144 SELECT CASE( ksbc ) !== fluxes over sea ice ==! 140 !145 ! 141 146 CASE( jp_usr ) !--- user defined formulation 142 CALL usrdef_sbc_ice_flx( kt, h_s, h_i ) 147 CALL usrdef_sbc_ice_flx( kt, h_s, h_i ) 148 ! 143 149 CASE( jp_blk, jp_abl ) !--- bulk formulation & ABL formulation 144 CALL blk_ice_2 ( t_su, h_s, h_i, alb_ice, sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), & 145 & sf(jp_slp)%fnow(:,:,1), sf(jp_qlw)%fnow(:,:,1), sf(jp_prec)%fnow(:,:,1), sf(jp_snow)%fnow(:,:,1) ) ! 150 CALL blk_ice_2 ( t_su, h_s, h_i, alb_ice, & 151 & theta_air_zt(:,:), q_air_zt(:,:), & ! #LB: known from "sbc_oce" module... 152 & sf(jp_slp)%fnow(:,:,1), sf(jp_qlw)%fnow(:,:,1), & 153 & sf(jp_prec)%fnow(:,:,1), sf(jp_snow)%fnow(:,:,1) ) 154 ! 146 155 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i ) 147 156 IF( nn_flxdist /= -1 ) CALL ice_flx_dist ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist ) … … 150 159 & CALL blk_ice_qcn ( ln_virtual_itd, t_su, t_bo, h_s, h_i ) 151 160 CASE ( jp_purecpl ) !--- coupled formulation 152 161 CALL sbc_cpl_ice_flx( picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i ) 153 162 IF( nn_flxdist /= -1 ) CALL ice_flx_dist ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist ) 154 163 END SELECT … … 163 172 zalb (:,:) = rn_alb_oce 164 173 ELSEWHERE 165 zmsk00(:,:) = 1._wp 174 zmsk00(:,:) = 1._wp 166 175 zalb (:,:) = SUM( alb_ice * a_i_b, dim=3 ) / at_i_b 167 176 END WHERE … … 185 194 !! *** ROUTINE ice_flx_dist *** 186 195 !! 187 !! ** Purpose : update the ice surface boundary condition by averaging 196 !! ** Purpose : update the ice surface boundary condition by averaging 188 197 !! and/or redistributing fluxes on ice categories 189 198 !! … … 192 201 !! ** Action : depends on k_flxdist 193 202 !! = -1 Do nothing (needs N(cat) fluxes) 194 !! = 0 Average N(cat) fluxes then apply the average over the N(cat) ice 203 !! = 0 Average N(cat) fluxes then apply the average over the N(cat) ice 195 204 !! = 1 Average N(cat) fluxes then redistribute over the N(cat) ice 196 205 !! using T-ice and albedo sensitivity … … 219 228 !!---------------------------------------------------------------------- 220 229 ! 221 WHERE ( at_i (:,:) > 0._wp ) ; z1_at_i(:,:) = 1._wp / at_i (:,:) 222 ELSEWHERE ; z1_at_i(:,:) = 0._wp 230 WHERE ( at_i (:,:) > 0._wp ) 231 z1_at_i(:,:) = 1._wp / at_i (:,:) 232 ELSEWHERE 233 z1_at_i(:,:) = 0._wp 223 234 END WHERE 224 235 225 236 SELECT CASE( k_flxdist ) !== averaged on all ice categories ==! 226 !237 ! 227 238 CASE( 0 , 1 ) 228 239 ! 229 ALLOCATE( z_qns_m(jpi,jpj), z_qsr_m(jpi,jpj), z_dqn_m(jpi,jpj), z_evap_m(jpi,jpj), z_devap_m(jpi,jpj) ) 240 ALLOCATE( z_qns_m(jpi,jpj), z_qsr_m(jpi,jpj), z_dqn_m(jpi,jpj), z_evap_m(jpi,jpj), z_devap_m(jpi,jpj) ) 230 241 ! 231 242 z_qns_m (:,:) = SUM( a_i(:,:,:) * pqns_ice (:,:,:) , dim=3 ) * z1_at_i(:,:) … … 242 253 END DO 243 254 ! 244 DEALLOCATE( z_qns_m, z_qsr_m, z_dqn_m, z_evap_m, z_devap_m ) 255 DEALLOCATE( z_qns_m, z_qsr_m, z_dqn_m, z_evap_m, z_devap_m ) 245 256 ! 246 257 END SELECT 247 258 ! 248 259 SELECT CASE( k_flxdist ) !== redistribution on all ice categories ==! 249 !260 ! 250 261 CASE( 1 , 2 ) 251 262 ! 252 ALLOCATE( zalb_m(jpi,jpj), ztem_m(jpi,jpj) ) 263 ALLOCATE( zalb_m(jpi,jpj), ztem_m(jpi,jpj) ) 253 264 ! 254 265 zalb_m(:,:) = SUM( a_i(:,:,:) * palb_ice(:,:,:) , dim=3 ) * z1_at_i(:,:) … … 260 271 END DO 261 272 ! 262 DEALLOCATE( zalb_m, ztem_m ) 273 DEALLOCATE( zalb_m, ztem_m ) 263 274 ! 264 275 END SELECT … … 272 283 !! 273 284 !! ** Purpose : Physical constants and parameters linked to the ice dynamics 274 !! 285 !! 275 286 !! ** Method : Read the namsbc namelist and check the ice-dynamic 276 287 !! parameter values called at the first timestep (nit000) -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/ICE/icestp.F90
r13641 r13655 8 8 !! aka Sea Ice cube for its nickname 9 9 !! 10 !! is originally based on LIM3, developed in Louvain-la-Neuve by: 10 !! is originally based on LIM3, developed in Louvain-la-Neuve by: 11 11 !! * Martin Vancoppenolle (UCL-ASTR, Belgium) 12 12 !! * Sylvain Bouillon (UCL-ASTR, Belgium) … … 140 140 IF( .NOT. Agrif_Root() ) nbstep_ice = MOD( nbstep_ice, Agrif_irhot() * Agrif_Parent(nn_fsbc) / nn_fsbc ) + 1 141 141 ! ! these calls must remain here for restartability purposes 142 CALL agrif_interp_ice( 'T' ) 142 CALL agrif_interp_ice( 'T' ) 143 143 CALL agrif_interp_ice( 'U' ) 144 144 CALL agrif_interp_ice( 'V' ) … … 152 152 ! utau_ice, vtau_ice = surface ice stress [N/m2] 153 153 !------------------------------------------------! 154 CALL ice_sbc_tau( kt, ksbc, utau_ice, vtau_ice ) 154 CALL ice_sbc_tau( kt, ksbc, utau_ice, vtau_ice ) 155 155 !-------------------------------------! 156 156 ! --- ice dynamics and advection --- ! 157 157 !-------------------------------------! 158 158 CALL diag_set0 ! set diag of mass, heat and salt fluxes to 0 159 CALL ice_rst_opn( kt ) ! Open Ice restart file (if necessary) 159 CALL ice_rst_opn( kt ) ! Open Ice restart file (if necessary) 160 160 ! 161 161 IF( ln_icedyn .AND. .NOT.lk_c1d ) & … … 169 169 ! !== previous lead fraction and ice volume for flux calculations 170 170 CALL ice_var_glo2eqv ! h_i and h_s for ice albedo calculation 171 CALL ice_var_agg(1) ! at_i for coupling 171 CALL ice_var_agg(1) ! at_i for coupling 172 172 CALL store_fields ! Store now ice values 173 173 ! … … 189 189 ! --- ice thermodynamics --- ! 190 190 !----------------------------! 191 IF( ln_icethd ) CALL ice_thd( kt ) ! -- Ice thermodynamics 191 IF( ln_icethd ) CALL ice_thd( kt ) ! -- Ice thermodynamics 192 192 ! 193 193 CALL diag_trends( 2 ) ! record thermo trends … … 197 197 CALL ice_update_flx( kt ) ! -- Update ocean surface mass, heat and salt fluxes 198 198 ! 199 IF( ln_icediahsb ) CALL ice_dia( kt ) ! -- Diagnostics outputs 200 ! 201 IF( ln_icediachk ) CALL ice_drift_wri( kt ) ! -- Diagnostics outputs for conservation 202 ! 203 CALL ice_wri( kt ) ! -- Ice outputs 204 ! 205 IF( lrst_ice ) CALL ice_rst_write( kt ) ! -- Ice restart file 199 IF( ln_icediahsb ) CALL ice_dia( kt ) ! -- Diagnostics outputs 200 ! 201 IF( ln_icediachk ) CALL ice_drift_wri( kt ) ! -- Diagnostics outputs for conservation 202 ! 203 CALL ice_wri( kt ) ! -- Ice outputs 204 ! 205 IF( lrst_ice ) CALL ice_rst_write( kt ) ! -- Ice restart file 206 206 ! 207 207 IF( ln_icectl ) CALL ice_ctl( kt ) ! -- Control checks … … 231 231 !!---------------------------------------------------------------------- 232 232 IF(lwp) WRITE(numout,*) 233 IF(lwp) WRITE(numout,*) 'Sea Ice Model: SI3 (Sea Ice modelling Integrated Initiative)' 233 IF(lwp) WRITE(numout,*) 'Sea Ice Model: SI3 (Sea Ice modelling Integrated Initiative)' 234 234 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' 235 235 IF(lwp) WRITE(numout,*) 236 IF(lwp) WRITE(numout,*) 'ice_init: Arrays allocation & Initialization of all routines & init state' 236 IF(lwp) WRITE(numout,*) 'ice_init: Arrays allocation & Initialization of all routines & init state' 237 237 IF(lwp) WRITE(numout,*) '~~~~~~~~' 238 238 ! … … 250 250 ! ! Allocate the ice arrays (sbc_ice already allocated in sbc_init) 251 251 ierr = ice_alloc () ! ice variables 252 ierr = ierr + sbc_ice_alloc () ! surface boundary conditions 252 ierr = ierr + sbc_ice_alloc () ! surface boundary conditions 253 253 ierr = ierr + ice1D_alloc () ! thermodynamics 254 254 ! … … 330 330 WRITE(numout,*) ' Ice dynamics (T) or not (F) ln_icedyn = ', ln_icedyn 331 331 WRITE(numout,*) ' Ice thermodynamics (T) or not (F) ln_icethd = ', ln_icethd 332 WRITE(numout,*) ' maximum ice concentration for NH = ', rn_amax_n 332 WRITE(numout,*) ' maximum ice concentration for NH = ', rn_amax_n 333 333 WRITE(numout,*) ' maximum ice concentration for SH = ', rn_amax_s 334 334 ENDIF … … 412 412 wfx_bom(ji,jj) = 0._wp ; wfx_sum(ji,jj) = 0._wp 413 413 wfx_res(ji,jj) = 0._wp ; wfx_sub(ji,jj) = 0._wp 414 wfx_spr(ji,jj) = 0._wp ; wfx_lam(ji,jj) = 0._wp 414 wfx_spr(ji,jj) = 0._wp ; wfx_lam(ji,jj) = 0._wp 415 415 wfx_snw_dyn(ji,jj) = 0._wp ; wfx_snw_sum(ji,jj) = 0._wp 416 416 wfx_snw_sub(ji,jj) = 0._wp ; wfx_ice_sub(ji,jj) = 0._wp 417 wfx_snw_sni(ji,jj) = 0._wp 417 wfx_snw_sni(ji,jj) = 0._wp 418 418 wfx_pnd(ji,jj) = 0._wp 419 419 -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/DOM/phycst.F90
r12489 r13655 7 7 !! 8.1 ! 1991-11 (G. Madec, M. Imbard) cosmetic changes 8 8 !! NEMO 1.0 ! 2002-08 (G. Madec, C. Ethe) F90, add ice constants 9 !! - ! 2006-08 (G. Madec) style 10 !! 3.2 ! 2006-08 (S. Masson, G. Madec) suppress useless variables + style 11 !! 3.4 ! 2011-11 (C. Harris) minor changes for CICE constants 9 !! - ! 2006-08 (G. Madec) style 10 !! 3.2 ! 2006-08 (S. Masson, G. Madec) suppress useless variables + style 11 !! 3.4 ! 2011-11 (C. Harris) minor changes for CICE constants 12 12 !!---------------------------------------------------------------------- 13 13 … … 26 26 REAL(wp), PUBLIC :: rad = 3.141592653589793_wp / 180._wp !: conversion from degre into radian 27 27 REAL(wp), PUBLIC :: rsmall = 0.5 * EPSILON( 1.e0 ) !: smallest real computer value 28 28 29 29 REAL(wp), PUBLIC :: rday = 24.*60.*60. !: day [s] 30 30 REAL(wp), PUBLIC :: rsiyea !: sideral year [s] … … 36 36 REAL(wp), PUBLIC :: omega !: earth rotation parameter [s-1] 37 37 REAL(wp), PUBLIC :: ra = 6371229._wp !: earth radius [m] 38 REAL(wp), PUBLIC :: grav = 9.80665_wp !: gravity [m/s2] 38 REAL(wp), PUBLIC :: grav = 9.80665_wp !: gravity [m/s2] 39 39 REAL(wp), PUBLIC :: rt0 = 273.15_wp !: freezing point of fresh water [Kelvin] 40 40 … … 43 43 REAL(wp), PUBLIC :: rcp !: ocean specific heat [J/Kelvin] 44 44 REAL(wp), PUBLIC :: r1_rcp !: = 1. / rcp [Kelvin/J] 45 REAL(wp), PUBLIC :: rho0_rcp !: = rho0 * rcp 45 REAL(wp), PUBLIC :: rho0_rcp !: = rho0 * rcp 46 46 REAL(wp), PUBLIC :: r1_rho0_rcp !: = 1. / ( rho0 * rcp ) 47 47 … … 52 52 REAL(wp), PUBLIC :: rLevap = 2.5e+6_wp !: latent heat of evaporation (water) 53 53 REAL(wp), PUBLIC :: vkarmn = 0.4_wp !: von Karman constant 54 REAL(wp), PUBLIC :: stefan = 5.67e-8_wp !: Stefan-Boltzmann constant 54 REAL(wp), PUBLIC :: vkarmn2 = 0.4_wp*0.4_wp !: square of von Karman constant 55 REAL(wp), PUBLIC :: stefan = 5.67e-8_wp !: Stefan-Boltzmann constant 55 56 56 57 REAL(wp), PUBLIC :: rhos = 330._wp !: volumic mass of snow [kg/m3] … … 68 69 !!---------------------------------------------------------------------- 69 70 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 70 !! $Id$ 71 !! $Id$ 71 72 !! Software governed by the CeCILL license (see ./LICENSE) 72 73 !!---------------------------------------------------------------------- 73 74 74 75 CONTAINS 75 76 76 77 SUBROUTINE phy_cst 77 78 !!---------------------------------------------------------------------- … … 86 87 omega = 7.292116e-05 87 88 #else 88 omega = 2._wp * rpi / rsiday 89 omega = 2._wp * rpi / rsiday 89 90 #endif 90 91 … … 125 126 WRITE(numout,*) ' salinity of ice (for pisces) = ', sice , ' psu' 126 127 WRITE(numout,*) ' salinity of sea (for pisces and isf) = ', soce , ' psu' 127 WRITE(numout,*) ' latent heat of evaporation (water) = ', rLevap , ' J/m^3' 128 WRITE(numout,*) ' von Karman constant = ', vkarmn 128 WRITE(numout,*) ' latent heat of evaporation (water) = ', rLevap , ' J/m^3' 129 WRITE(numout,*) ' von Karman constant = ', vkarmn 129 130 WRITE(numout,*) ' Stefan-Boltzmann constant = ', stefan , ' J/s/m^2/K^4' 130 131 WRITE(numout,*) -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/SBC/sbc_ice.F90
r13472 r13655 99 99 #endif 100 100 101 REAL(wp), PUBLIC, SAVE :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-]101 !#LB: REAL(wp), PUBLIC, SAVE :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] !#LB => moved to sbc_phy.F90 !!! 102 102 103 103 !! arrays relating to embedding ice in the ocean … … 168 168 LOGICAL , PUBLIC, PARAMETER :: lk_si3 = .FALSE. !: no SI3 ice model 169 169 LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE ice model 170 REAL(wp) , PUBLIC, PARAMETER :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-]170 !#LB: REAL(wp) , PUBLIC, PARAMETER :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] !#LB => moved to sbc_phy.F90 !!! 171 171 INTEGER , PUBLIC, PARAMETER :: jpl = 1 172 172 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ! jpi, jpj -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/SBC/sbc_oce.F90
r13472 r13655 159 159 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_m !: mean (nn_fsbc time-step) fraction of solar net radiation absorbed in the 1st T level [-] 160 160 161 !#LB: 162 !!---------------------------------------------------------------------- 163 !! Surface atmospheric fields 164 !!---------------------------------------------------------------------- 165 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_air_zt !: specific humidity of air at z=zt [kg/kg]ww 166 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: theta_air_zt !: potential temperature of air at z=zt [K] 167 !#LB. 168 169 161 170 !! * Substitutions 162 171 # include "do_loop_substitute.h90" … … 172 181 !! *** FUNCTION sbc_oce_alloc *** 173 182 !!--------------------------------------------------------------------- 174 INTEGER :: ierr( 5)183 INTEGER :: ierr(6) 175 184 !!--------------------------------------------------------------------- 176 185 ierr(:) = 0 … … 194 203 ! 195 204 ALLOCATE( e3t_m(jpi,jpj) , STAT=ierr(5) ) 205 ! 206 ALLOCATE( q_air_zt(jpi,jpj) , theta_air_zt(jpi,jpj) , STAT=ierr(6) ) !#LB 196 207 ! 197 208 sbc_oce_alloc = MAXVAL( ierr ) -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/SBC/sbc_phy.F90
r13654 r13655 1 MODULE sbc blk_phy1 MODULE sbc_phy 2 2 !!====================================================================== 3 !! *** MODULE sbc blk_phy ***3 !! *** MODULE sbc_phy *** 4 4 !! A set of functions to compute air themodynamics parameters 5 5 !! needed by Aerodynamic Bulk Formulas 6 6 !!===================================================================== 7 !! 4. 0 ! 2019L. Brodeau from AeroBulk package (https://github.com/brodeau/aerobulk/)7 !! 4.x ! 2020 L. Brodeau from AeroBulk package (https://github.com/brodeau/aerobulk/) 8 8 !!---------------------------------------------------------------------- 9 9 … … 14 14 !! cp_air : specific heat of (moist) air (depends spec. hum. q_air) 15 15 !! gamma_moist : adiabatic lapse-rate of moist air 16 !! One_on_L : 1. / ( Monin-Obukhov length )16 !! One_on_L : 1. / ( Obukhov length ) 17 17 !! Ri_bulk : bulk Richardson number aka BRN 18 18 !! q_sat : saturation humidity as a function of SLP and temperature … … 24 24 IMPLICIT NONE 25 25 PRIVATE 26 27 INTEGER , PARAMETER, PUBLIC :: nb_iter0 = 5 ! Default number of itterations in bulk-param algorithms (can be overriden b.m.o `nb_iter` optional argument) 26 28 27 29 !! (mainly removed from sbcblk.F90) … … 33 35 REAL(wp), PARAMETER, PUBLIC :: rctv0 = R_vap/R_dry - 1._wp !: for virtual temperature (== (1-eps)/eps) => ~ 0.608 34 36 REAL(wp), PARAMETER, PUBLIC :: rCp_air = 1000.5_wp !: specific heat of air (only used for ice fluxes now...) 35 REAL(wp), PARAMETER, PUBLIC :: rCd_ice = 1.4e-3_wp !: transfer coefficient over ice36 37 REAL(wp), PARAMETER, PUBLIC :: albo = 0.066_wp !: ocean albedo assumed to be constant 37 38 ! … … 44 45 REAL(wp), PARAMETER, PUBLIC :: rk0_w = 0.6_wp !: thermal conductivity of water (at 20C) [W/m/K] 45 46 ! 46 REAL(wp), PARAMETER, PUBLIC :: emiss_w = 1._wp !: Surface emissivity (black-body long-wave radiation) of sea-water [] 47 ! !: Theoretically close to 0.97! Yet, taken equal as 1 to account for 48 ! !: the small fraction of downwelling longwave reflected at the 49 ! !: surface (Lind & Katsaros, 1986) 47 REAL(wp), PARAMETER, PUBLIC :: emiss_w = 0.98_wp !: Long-wave (thermal) emissivity of sea-water [] 48 ! 49 REAL(wp), PARAMETER, PUBLIC :: emiss_i = 0.996_wp !: " for ice and snow => but Rees 1993 suggests can be lower in winter on fresh snow... 0.72 ... 50 51 REAL(wp), PARAMETER, PUBLIC :: wspd_thrshld_ice = 0.2_wp !: minimum scalar wind speed accepted over sea-ice... [m/s] 52 53 ! 50 54 REAL(wp), PARAMETER, PUBLIC :: rdct_qsat_salt = 0.98_wp !: reduction factor on specific humidity at saturation (q_sat(T_s)) due to salt 51 55 REAL(wp), PARAMETER, PUBLIC :: rtt0 = 273.16_wp !: triple point of temperature [K] … … 54 58 ! => see eq.(14) in Fairall et al. 1996 (eq.(6) of Zeng aand Beljaars is WRONG! (typo?) 55 59 60 REAL(wp), PARAMETER, PUBLIC :: z0_sea_max = 0.0025_wp !: maximum realistic value for roughness length of sea-surface... [m] 61 62 REAL(wp), PUBLIC, SAVE :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] 63 64 65 REAL(wp), PARAMETER, PUBLIC :: Cx_min = 0.1E-3_wp ! smallest value allowed for bulk transfer coefficients (usually in stable conditions with now wind) 66 67 REAL(wp), PARAMETER :: & 68 !! Constants for Goff formula in the presence of ice: 69 & rAg_i = -9.09718_wp, & 70 & rBg_i = -3.56654_wp, & 71 & rCg_i = 0.876793_wp, & 72 & rDg_i = LOG10(6.1071_wp) 73 74 REAL(wp), PARAMETER :: rc_louis = 5._wp 75 REAL(wp), PARAMETER :: rc2_louis = rc_louis * rc_louis 76 REAL(wp), PARAMETER :: ram_louis = 2. * rc_louis 77 REAL(wp), PARAMETER :: rah_louis = 3. * rc_louis 78 79 80 INTERFACE virt_temp 81 MODULE PROCEDURE virt_temp_vctr, virt_temp_sclr 82 END INTERFACE virt_temp 83 84 INTERFACE visc_air 85 MODULE PROCEDURE visc_air_vctr, visc_air_sclr 86 END INTERFACE visc_air 56 87 57 88 INTERFACE gamma_moist … … 63 94 END INTERFACE e_sat 64 95 96 INTERFACE e_sat_ice 97 MODULE PROCEDURE e_sat_ice_vctr, e_sat_ice_sclr 98 END INTERFACE e_sat_ice 99 INTERFACE de_sat_dt_ice 100 MODULE PROCEDURE de_sat_dt_ice_vctr, de_sat_dt_ice_sclr 101 END INTERFACE de_sat_dt_ice 102 103 INTERFACE Ri_bulk 104 MODULE PROCEDURE Ri_bulk_vctr, Ri_bulk_sclr 105 END INTERFACE Ri_bulk 106 107 INTERFACE q_sat 108 MODULE PROCEDURE q_sat_vctr, q_sat_sclr 109 END INTERFACE q_sat 110 111 INTERFACE dq_sat_dt_ice 112 MODULE PROCEDURE dq_sat_dt_ice_vctr, dq_sat_dt_ice_sclr 113 END INTERFACE dq_sat_dt_ice 114 65 115 INTERFACE L_vap 66 116 MODULE PROCEDURE L_vap_vctr, L_vap_sclr … … 83 133 END INTERFACE bulk_formula 84 134 135 INTERFACE qlw_net 136 MODULE PROCEDURE qlw_net_vctr, qlw_net_sclr 137 END INTERFACE qlw_net 138 139 INTERFACE f_m_louis 140 MODULE PROCEDURE f_m_louis_vctr, f_m_louis_sclr 141 END INTERFACE f_m_louis 142 143 INTERFACE f_h_louis 144 MODULE PROCEDURE f_h_louis_vctr, f_h_louis_sclr 145 END INTERFACE f_h_louis 85 146 86 147 … … 95 156 PUBLIC q_sat 96 157 PUBLIC q_air_rh 158 PUBLIC dq_sat_dt_ice 97 159 !: 98 160 PUBLIC update_qnsol_tau 99 161 PUBLIC alpha_sw 100 162 PUBLIC bulk_formula 163 PUBLIC qlw_net 164 ! 165 PUBLIC f_m_louis, f_h_louis 166 PUBLIC z0_from_Cd 167 PUBLIC Cd_from_z0 168 PUBLIC UN10_from_ustar 169 PUBLIC UN10_from_CD 170 PUBLIC z0tq_LKB 101 171 102 172 !! * Substitutions … … 109 179 CONTAINS 110 180 111 FUNCTION virt_temp( pta, pqa ) 181 182 FUNCTION virt_temp_sclr( pta, pqa ) 112 183 !!------------------------------------------------------------------------ 113 184 !! 114 !! Compute the (absolute/potential) virtual temperature, knowingthe185 !! Compute the (absolute/potential) VIRTUAL temperature, based on the 115 186 !! (absolute/potential) temperature and specific humidity 116 187 !! 117 !! If input temperature is absolute then output vi tual temperature is absolute118 !! If input temperature is potential then output vi tual temperature is potential188 !! If input temperature is absolute then output virtual temperature is absolute 189 !! If input temperature is potential then output virtual temperature is potential 119 190 !! 120 191 !! Author: L. Brodeau, June 2019 / AeroBulk 121 192 !! (https://github.com/brodeau/aerobulk/) 122 193 !!------------------------------------------------------------------------ 123 REAL(wp) , DIMENSION(jpi,jpj) :: virt_temp !: 1./(Monin Obukhov length) [m^-1]124 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta, & !: absolute or potetntial air temperature [K]125 & pqa!: specific humidity of air [kg/kg]194 REAL(wp) :: virt_temp_sclr !: virtual temperature [K] 195 REAL(wp), INTENT(in) :: pta !: absolute or potential air temperature [K] 196 REAL(wp), INTENT(in) :: pqa !: specific humidity of air [kg/kg] 126 197 !!------------------------------------------------------------------- 127 198 ! 128 virt_temp (:,:) = pta(:,:) * (1._wp + rctv0*pqa(:,:))129 !! 130 !! This is exactly the same sing that:131 !! virt_temp = pta * ( pwa + reps0) / (reps0*(1.+pwa))199 virt_temp_sclr = pta * (1._wp + rctv0*pqa) 200 !! 201 !! This is exactly the same thing as: 202 !! virt_temp_sclr = pta * ( pwa + reps0) / (reps0*(1.+pwa)) 132 203 !! with wpa (mixing ration) defined as : pwa = pqa/(1.-pqa) 133 204 ! 134 END FUNCTION virt_temp 135 136 FUNCTION rho_air_vctr( ptak, pqa, pslp ) 205 END FUNCTION virt_temp_sclr 206 !! 207 FUNCTION virt_temp_vctr( pta, pqa ) 208 REAL(wp), DIMENSION(jpi,jpj) :: virt_temp_vctr !: virtual temperature [K] 209 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute or potential air temperature [K] 210 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: specific humidity of air [kg/kg] 211 virt_temp_vctr(:,:) = pta(:,:) * (1._wp + rctv0*pqa(:,:)) 212 END FUNCTION virt_temp_vctr 213 !=============================================================================================== 214 215 216 FUNCTION rho_air_vctr( ptak, pqa, ppa ) 137 217 !!------------------------------------------------------------------------------- 138 218 !! *** FUNCTION rho_air_vctr *** … … 144 224 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K] 145 225 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg] 146 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p slp! pressure in [Pa]226 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! pressure in [Pa] 147 227 REAL(wp), DIMENSION(jpi,jpj) :: rho_air_vctr ! density of moist air [kg/m^3] 148 228 !!------------------------------------------------------------------------------- 149 rho_air_vctr = MAX( p slp/ (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp )229 rho_air_vctr = MAX( ppa / (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp ) 150 230 END FUNCTION rho_air_vctr 151 231 152 FUNCTION rho_air_sclr( ptak, pqa, p slp)232 FUNCTION rho_air_sclr( ptak, pqa, ppa ) 153 233 !!------------------------------------------------------------------------------- 154 234 !! *** FUNCTION rho_air_sclr *** … … 160 240 REAL(wp), INTENT(in) :: ptak ! air temperature [K] 161 241 REAL(wp), INTENT(in) :: pqa ! air specific humidity [kg/kg] 162 REAL(wp), INTENT(in) :: p slp! pressure in [Pa]242 REAL(wp), INTENT(in) :: ppa ! pressure in [Pa] 163 243 REAL(wp) :: rho_air_sclr ! density of moist air [kg/m^3] 164 244 !!------------------------------------------------------------------------------- 165 rho_air_sclr = MAX( p slp/ (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp )245 rho_air_sclr = MAX( ppa / (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp ) 166 246 END FUNCTION rho_air_sclr 167 247 168 248 169 249 170 FUNCTION visc_air(ptak) 171 !!---------------------------------------------------------------------------------- 172 !! Air kinetic viscosity (m^2/s) given from temperature in degrees... 250 251 FUNCTION visc_air_sclr(ptak) 252 !!---------------------------------------------------------------------------------- 253 !! Air kinetic viscosity (m^2/s) given from air temperature in Kelvin 173 254 !! 174 255 !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) 175 256 !!---------------------------------------------------------------------------------- 176 REAL(wp), DIMENSION(jpi,jpj) :: visc_air ! 257 REAL(wp) :: visc_air_sclr ! kinetic viscosity (m^2/s) 258 REAL(wp), INTENT(in) :: ptak ! air temperature in (K) 259 ! 260 REAL(wp) :: ztc, ztc2 ! local scalar 261 !!---------------------------------------------------------------------------------- 262 ! 263 ztc = ptak - rt0 ! air temp, in deg. C 264 ztc2 = ztc*ztc 265 visc_air_sclr = 1.326e-5*(1. + 6.542E-3*ztc + 8.301e-6*ztc2 - 4.84e-9*ztc2*ztc) 266 ! 267 END FUNCTION visc_air_sclr 268 269 FUNCTION visc_air_vctr(ptak) 270 REAL(wp), DIMENSION(jpi,jpj) :: visc_air_vctr ! kinetic viscosity (m^2/s) 177 271 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature in (K) 178 !179 272 INTEGER :: ji, jj ! dummy loop indices 180 REAL(wp) :: ztc, ztc2 ! local scalar 181 !!---------------------------------------------------------------------------------- 182 ! 183 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 184 ztc = ptak(ji,jj) - rt0 ! air temp, in deg. C 185 ztc2 = ztc*ztc 186 visc_air(ji,jj) = 1.326e-5*(1. + 6.542E-3*ztc + 8.301e-6*ztc2 - 4.84e-9*ztc2*ztc) 187 END_2D 188 ! 189 END FUNCTION visc_air 273 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 274 visc_air_vctr(ji,jj) = visc_air_sclr( ptak(ji,jj) ) 275 END_2D 276 END FUNCTION visc_air_vctr 277 190 278 191 279 FUNCTION L_vap_vctr( psst ) … … 252 340 253 341 254 255 256 FUNCTION gamma_moist_vctr( ptak, pqa ) 257 !!---------------------------------------------------------------------------------- 258 !! *** FUNCTION gamma_moist_vctr *** 259 !! 342 !=============================================================================================== 343 FUNCTION gamma_moist_sclr( ptak, pqa ) 344 !!---------------------------------------------------------------------------------- 260 345 !! ** Purpose : Compute the moist adiabatic lapse-rate. 261 346 !! => http://glossary.ametsoc.org/wiki/Moist-adiabatic_lapse_rate 262 347 !! => http://www.geog.ucsb.edu/~joel/g266_s10/lecture_notes/chapt03/oh10_3_01/oh10_3_01.html 263 348 !! 264 !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)265 !!----------------------------------------------------------------------------------266 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K]267 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity [kg/kg]268 REAL(wp), DIMENSION(jpi,jpj) :: gamma_moist_vctr ! moist adiabatic lapse-rate269 !270 INTEGER :: ji, jj ! dummy loop indices271 !!----------------------------------------------------------------------------------272 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )273 gamma_moist_vctr(ji,jj) = gamma_moist_sclr( ptak(ji,jj), pqa(ji,jj) )274 END_2D275 END FUNCTION gamma_moist_vctr276 277 FUNCTION gamma_moist_sclr( ptak, pqa )278 !!----------------------------------------------------------------------------------279 !! ** Purpose : Compute the moist adiabatic lapse-rate.280 !! => http://glossary.ametsoc.org/wiki/Moist-adiabatic_lapse_rate281 !! => http://www.geog.ucsb.edu/~joel/g266_s10/lecture_notes/chapt03/oh10_3_01/oh10_3_01.html282 !!283 349 !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) 284 350 !!---------------------------------------------------------------------------------- 285 REAL(wp) :: gamma_moist_sclr 286 REAL(wp), INTENT(in) :: ptak, pqa ! air temperature (K) and specific humidity (kg/kg) 287 ! 288 REAL(wp) :: zta, zqa, zwa, ziRT ! local scalar 351 REAL(wp) :: gamma_moist_sclr ! [K/m] 352 REAL(wp), INTENT(in) :: ptak ! absolute air temperature [K] !#LB: double check it's absolute !!! 353 REAL(wp), INTENT(in) :: pqa ! specific humidity [kg/kg] 354 ! 355 REAL(wp) :: zta, zqa, zwa, ziRT, zLvap ! local scalars 289 356 !!---------------------------------------------------------------------------------- 290 357 zta = MAX( ptak, 180._wp) ! prevents screw-up over masked regions where field == 0. … … 293 360 zwa = zqa / (1._wp - zqa) ! w is mixing ratio w = q/(1-q) | q = w/(1+w) 294 361 ziRT = 1._wp / (R_dry*zta) ! 1/RT 295 gamma_moist_sclr = grav * ( 1._wp + rLevap*zwa*ziRT ) / ( rCp_dry + rLevap*rLevap*zwa*reps0*ziRT/zta ) 362 zLvap = L_vap_sclr( ptak ) 363 !! 364 gamma_moist_sclr = grav * ( 1._wp + zLvap*zwa*ziRT ) / ( rCp_dry + zLvap*zLvap*zwa*reps0*ziRT/zta ) 296 365 !! 297 366 END FUNCTION gamma_moist_sclr 367 !! 368 FUNCTION gamma_moist_vctr( ptak, pqa ) 369 REAL(wp), DIMENSION(jpi,jpj) :: gamma_moist_vctr 370 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak 371 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa 372 INTEGER :: ji, jj 373 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 374 gamma_moist_vctr(ji,jj) = gamma_moist_sclr( ptak(ji,jj), pqa(ji,jj) ) 375 END_2D 376 END FUNCTION gamma_moist_vctr 377 !=============================================================================================== 378 298 379 299 380 FUNCTION One_on_L( ptha, pqa, pus, pts, pqs ) 300 381 !!------------------------------------------------------------------------ 301 382 !! 302 !! Evaluates the 1./( Monin Obukhov length) from air temperature and303 !! specific humidity, and frictional scales u*, t* and q*304 !! 305 !! Author: L. Brodeau, June 201 6/ AeroBulk383 !! Evaluates the 1./(Obukhov length) from air temperature, 384 !! air specific humidity, and frictional scales u*, t* and q* 385 !! 386 !! Author: L. Brodeau, June 2019 / AeroBulk 306 387 !! (https://github.com/brodeau/aerobulk/) 307 388 !!------------------------------------------------------------------------ 308 REAL(wp), DIMENSION(jpi,jpj) :: One_on_L !: 1./(Monin Obukhov length) [m^-1] 309 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha, & !: average potetntial air temperature [K] 310 & pqa, & !: average specific humidity of air [kg/kg] 311 & pus, pts, pqs !: frictional velocity, temperature and humidity 389 REAL(wp), DIMENSION(jpi,jpj) :: One_on_L !: 1./(Obukhov length) [m^-1] 390 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha !: reference potential temperature of air [K] 391 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: reference specific humidity of air [kg/kg] 392 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: u*: friction velocity [m/s] 393 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pts, pqs !: \theta* and q* friction aka turb. scales for temp. and spec. hum. 312 394 ! 313 395 INTEGER :: ji, jj ! dummy loop indices … … 316 398 ! 317 399 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 318 319 320 321 322 323 324 325 326 327 328 400 ! 401 zqa = (1._wp + rctv0*pqa(ji,jj)) 402 ! 403 ! The main concern is to know whether, the vertical turbulent flux of virtual temperature, < u' theta_v' > is estimated with: 404 ! a/ -u* [ theta* (1 + 0.61 q) + 0.61 theta q* ] => this is the one that seems correct! chose this one! 405 ! or 406 ! b/ -u* [ theta* + 0.61 theta q* ] 407 ! 408 One_on_L(ji,jj) = grav*vkarmn*( pts(ji,jj)*zqa + rctv0*ptha(ji,jj)*pqs(ji,jj) ) & 409 & / MAX( pus(ji,jj)*pus(ji,jj)*ptha(ji,jj)*zqa , 1.E-9_wp ) 410 ! 329 411 END_2D 330 412 ! … … 333 415 END FUNCTION One_on_L 334 416 335 FUNCTION Ri_bulk( pz, psst, ptha, pssq, pqa, pub ) 417 418 !=============================================================================================== 419 FUNCTION Ri_bulk_sclr( pz, psst, ptha, pssq, pqa, pub, pta_layer, pqa_layer ) 336 420 !!---------------------------------------------------------------------------------- 337 421 !! Bulk Richardson number according to "wide-spread equation"... 338 422 !! 423 !! Reminder: the Richardson number is the ratio "buoyancy" / "shear" 424 !! 339 425 !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) 340 426 !!---------------------------------------------------------------------------------- 341 REAL(wp), DIMENSION(jpi,jpj) :: Ri_bulk 427 REAL(wp) :: Ri_bulk_sclr 428 REAL(wp), INTENT(in) :: pz ! height above the sea (aka "delta z") [m] 429 REAL(wp), INTENT(in) :: psst ! SST [K] 430 REAL(wp), INTENT(in) :: ptha ! pot. air temp. at height "pz" [K] 431 REAL(wp), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg] 432 REAL(wp), INTENT(in) :: pqa ! air spec. hum. at height "pz" [kg/kg] 433 REAL(wp), INTENT(in) :: pub ! bulk wind speed [m/s] 434 REAL(wp), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K] 435 REAL(wp), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg] 436 !! 437 LOGICAL :: l_ptqa_l_prvd = .FALSE. 438 REAL(wp) :: zqa, zta, zgamma, zdthv, ztv, zsstv ! local scalars 439 !!------------------------------------------------------------------- 440 IF( PRESENT(pta_layer) .AND. PRESENT(pqa_layer) ) l_ptqa_l_prvd=.TRUE. 441 ! 442 zsstv = virt_temp_sclr( psst, pssq ) ! virtual SST (absolute==potential because z=0!) 443 ! 444 zdthv = virt_temp_sclr( ptha, pqa ) - zsstv ! air-sea delta of "virtual potential temperature" 445 ! 446 !! ztv: estimate of the ABSOLUTE virtual temp. within the layer 447 IF( l_ptqa_l_prvd ) THEN 448 ztv = virt_temp_sclr( pta_layer, pqa_layer ) 449 ELSE 450 zqa = 0.5_wp*( pqa + pssq ) ! ~ mean q within the layer... 451 zta = 0.5_wp*( psst + ptha - gamma_moist(ptha, zqa)*pz ) ! ~ mean absolute temperature of air within the layer 452 zta = 0.5_wp*( psst + ptha - gamma_moist( zta, zqa)*pz ) ! ~ mean absolute temperature of air within the layer 453 zgamma = gamma_moist(zta, zqa) ! Adiabatic lapse-rate for moist air within the layer 454 ztv = 0.5_wp*( zsstv + virt_temp_sclr( ptha-zgamma*pz, pqa ) ) 455 END IF 456 ! 457 Ri_bulk_sclr = grav*zdthv*pz / ( ztv*pub*pub ) ! the usual definition of Ri_bulk_sclr 458 ! 459 END FUNCTION Ri_bulk_sclr 460 !! 461 FUNCTION Ri_bulk_vctr( pz, psst, ptha, pssq, pqa, pub, pta_layer, pqa_layer ) 462 REAL(wp), DIMENSION(jpi,jpj) :: Ri_bulk_vctr 342 463 REAL(wp) , INTENT(in) :: pz ! height above the sea (aka "delta z") [m] 343 464 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! SST [K] … … 346 467 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air spec. hum. at height "pz" [kg/kg] 347 468 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub ! bulk wind speed [m/s] 348 ! 349 INTEGER :: ji, jj ! dummy loop indices 350 REAL(wp) :: zqa, zta, zgamma, zdth_v, ztv, zsstv ! local scalars 351 !!------------------------------------------------------------------- 352 ! 353 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 354 ! 355 zqa = 0.5_wp*(pqa(ji,jj)+pssq(ji,jj)) ! ~ mean q within the layer... 356 zta = 0.5_wp*( psst(ji,jj) + ptha(ji,jj) - gamma_moist(ptha(ji,jj),zqa)*pz ) ! ~ mean absolute temperature of air within the layer 357 zta = 0.5_wp*( psst(ji,jj) + ptha(ji,jj) - gamma_moist(zta, zqa)*pz ) ! ~ mean absolute temperature of air within the layer 358 zgamma = gamma_moist(zta, zqa) ! Adiabatic lapse-rate for moist air within the layer 359 ! 360 zsstv = psst(ji,jj)*(1._wp + rctv0*pssq(ji,jj)) ! absolute==potential virtual SST (absolute==potential because z=0!) 361 ! 362 zdth_v = ptha(ji,jj)*(1._wp + rctv0*pqa(ji,jj)) - zsstv ! air-sea delta of "virtual potential temperature" 363 ! 364 ztv = 0.5_wp*( zsstv + (ptha(ji,jj) - zgamma*pz)*(1._wp + rctv0*pqa(ji,jj)) ) ! ~ mean absolute virtual temp. within the layer 365 ! 366 Ri_bulk(ji,jj) = grav*zdth_v*pz / ( ztv*pub(ji,jj)*pub(ji,jj) ) ! the usual definition of Ri_bulk 367 ! 368 END_2D 369 END FUNCTION Ri_bulk 370 371 372 FUNCTION e_sat_vctr(ptak) 373 !!************************************************** 374 !! ptak: air temperature [K] 375 !! e_sat: water vapor at saturation [Pa] 376 !! 377 !! Recommended by WMO 378 !! 379 !! Goff, J. A., 1957: Saturation pressure of water on the new kelvin 380 !! temperature scale. Transactions of the American society of heating 381 !! and ventilating engineers, 347–354. 382 !! 383 !! rt0 should be 273.16 (triple point of water) and not 273.15 like here 384 !!************************************************** 385 386 REAL(wp), DIMENSION(jpi,jpj) :: e_sat_vctr !: vapour pressure at saturation [Pa] 387 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: temperature (K) 388 389 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp 390 391 ALLOCATE ( ztmp(jpi,jpj) ) 392 393 ztmp(:,:) = rtt0/ptak(:,:) 394 395 e_sat_vctr = 100.*( 10.**(10.79574*(1. - ztmp) - 5.028*LOG10(ptak/rtt0) & 396 & + 1.50475*10.**(-4)*(1. - 10.**(-8.2969*(ptak/rtt0 - 1.)) ) & 397 & + 0.42873*10.**(-3)*(10.**(4.76955*(1. - ztmp)) - 1.) + 0.78614) ) 398 399 DEALLOCATE ( ztmp ) 400 401 END FUNCTION e_sat_vctr 402 403 469 REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K] 470 REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg] 471 !! 472 LOGICAL :: l_ptqa_l_prvd = .FALSE. 473 INTEGER :: ji, jj 474 IF( PRESENT(pta_layer) .AND. PRESENT(pqa_layer) ) l_ptqa_l_prvd=.TRUE. 475 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 476 IF( l_ptqa_l_prvd ) THEN 477 Ri_bulk_vctr(ji,jj) = Ri_bulk_sclr( pz, psst(ji,jj), ptha(ji,jj), pssq(ji,jj), pqa(ji,jj), pub(ji,jj), & 478 & pta_layer=pta_layer(ji,jj ), pqa_layer=pqa_layer(ji,jj ) ) 479 ELSE 480 Ri_bulk_vctr(ji,jj) = Ri_bulk_sclr( pz, psst(ji,jj), ptha(ji,jj), pssq(ji,jj), pqa(ji,jj), pub(ji,jj) ) 481 END IF 482 END_2D 483 END FUNCTION Ri_bulk_vctr 484 !=============================================================================================== 485 486 !=============================================================================================== 404 487 FUNCTION e_sat_sclr( ptak ) 405 488 !!---------------------------------------------------------------------------------- … … 413 496 !! Note: what rt0 should be here, is 273.16 (triple point of water) and not 273.15 like here 414 497 !!---------------------------------------------------------------------------------- 498 REAL(wp) :: e_sat_sclr ! water vapor at saturation [kg/kg] 415 499 REAL(wp), INTENT(in) :: ptak ! air temperature [K] 416 REAL(wp) :: e_sat_sclr ! water vapor at saturation [kg/kg]417 !418 500 REAL(wp) :: zta, ztmp ! local scalar 419 501 !!---------------------------------------------------------------------------------- 420 !421 502 zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... 422 ztmp = rt0 / zta 503 ztmp = rt0 / zta !#LB: rt0 or rtt0 ???? (273.15 vs 273.16 ) 423 504 ! 424 505 ! Vapour pressure at saturation [Pa] : WMO, (Goff, 1957) … … 428 509 ! 429 510 END FUNCTION e_sat_sclr 430 431 432 FUNCTION q_sat( ptak, pslp ) 433 !!---------------------------------------------------------------------------------- 434 !! *** FUNCTION q_sat *** 435 !! 436 !! ** Purpose : Specific humidity at saturation in [kg/kg] 437 !! Based on accurate estimate of "e_sat" 438 !! aka saturation water vapor (Goff, 1957) 511 !! 512 FUNCTION e_sat_vctr(ptak) 513 REAL(wp), DIMENSION(jpi,jpj) :: e_sat_vctr !: vapour pressure at saturation [Pa] 514 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: temperature (K) 515 INTEGER :: ji, jj ! dummy loop indices 516 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 517 e_sat_vctr(ji,jj) = e_sat_sclr(ptak(ji,jj)) 518 END_2D 519 END FUNCTION e_sat_vctr 520 !=============================================================================================== 521 522 !=============================================================================================== 523 FUNCTION e_sat_ice_sclr(ptak) 524 !!--------------------------------------------------------------------------------- 525 !! Same as "e_sat" but over ice rather than water! 526 !!--------------------------------------------------------------------------------- 527 REAL(wp) :: e_sat_ice_sclr !: vapour pressure at saturation in presence of ice [Pa] 528 REAL(wp), INTENT(in) :: ptak 529 !! 530 REAL(wp) :: zta, zle, ztmp 531 !!--------------------------------------------------------------------------------- 532 zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... 533 ztmp = rtt0/zta 534 !! 535 zle = rAg_i*(ztmp - 1._wp) + rBg_i*LOG10(ztmp) + rCg_i*(1._wp - zta/rtt0) + rDg_i 536 !! 537 e_sat_ice_sclr = 100._wp * 10._wp**zle 538 END FUNCTION e_sat_ice_sclr 539 !! 540 FUNCTION e_sat_ice_vctr(ptak) 541 !! Same as "e_sat" but over ice rather than water! 542 REAL(wp), DIMENSION(jpi,jpj) :: e_sat_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] 543 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak 544 INTEGER :: ji, jj 545 !!---------------------------------------------------------------------------------- 546 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 547 e_sat_ice_vctr(ji,jj) = e_sat_ice_sclr( ptak(ji,jj) ) 548 END_2D 549 END FUNCTION e_sat_ice_vctr 550 !! 551 FUNCTION de_sat_dt_ice_sclr(ptak) 552 !!--------------------------------------------------------------------------------- 553 !! d [ e_sat_ice ] / dT (derivative / temperature) 554 !! Analytical exact formulation: double checked!!! 555 !! => DOUBLE-check possible / finite-difference version with "./bin/test_phymbl.x" 556 !!--------------------------------------------------------------------------------- 557 REAL(wp) :: de_sat_dt_ice_sclr !: [Pa/K] 558 REAL(wp), INTENT(in) :: ptak 559 !! 560 REAL(wp) :: zta, zde 561 !!--------------------------------------------------------------------------------- 562 zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... 563 !! 564 zde = -(rAg_i*rtt0)/(zta*zta) - rBg_i/(zta*LOG(10._wp)) - rCg_i/rtt0 565 !! 566 de_sat_dt_ice_sclr = LOG(10._wp) * zde * e_sat_ice_sclr(zta) 567 END FUNCTION de_sat_dt_ice_sclr 568 !! 569 FUNCTION de_sat_dt_ice_vctr(ptak) 570 !! Same as "e_sat" but over ice rather than water! 571 REAL(wp), DIMENSION(jpi,jpj) :: de_sat_dt_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] 572 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak 573 INTEGER :: ji, jj 574 !!---------------------------------------------------------------------------------- 575 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 576 de_sat_dt_ice_vctr(ji,jj) = de_sat_dt_ice_sclr( ptak(ji,jj) ) 577 END_2D 578 END FUNCTION de_sat_dt_ice_vctr 579 580 581 582 !=============================================================================================== 583 584 !=============================================================================================== 585 FUNCTION q_sat_sclr( pta, ppa, l_ice ) 586 !!--------------------------------------------------------------------------------- 587 !! *** FUNCTION q_sat_sclr *** 588 !! 589 !! ** Purpose : Conputes specific humidity of air at saturation 439 590 !! 440 591 !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) 441 592 !!---------------------------------------------------------------------------------- 442 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K] 443 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pslp ! sea level atmospheric pressure [Pa] 444 REAL(wp), DIMENSION(jpi,jpj) :: q_sat ! Specific humidity at saturation [kg/kg] 445 ! 446 INTEGER :: ji, jj ! dummy loop indices 447 REAL(wp) :: ze_sat ! local scalar 448 !!---------------------------------------------------------------------------------- 449 ! 450 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 451 ! 452 ze_sat = e_sat_sclr( ptak(ji,jj) ) 453 ! 454 q_sat(ji,jj) = reps0 * ze_sat/( pslp(ji,jj) - (1._wp - reps0)*ze_sat ) 455 ! 456 END_2D 457 ! 458 END FUNCTION q_sat 459 460 FUNCTION q_air_rh(prha, ptak, pslp) 593 REAL(wp) :: q_sat_sclr 594 REAL(wp), INTENT(in) :: pta !: absolute temperature of air [K] 595 REAL(wp), INTENT(in) :: ppa !: atmospheric pressure [Pa] 596 LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice 597 REAL(wp) :: ze_s 598 LOGICAL :: lice 599 !!---------------------------------------------------------------------------------- 600 lice = .FALSE. 601 IF( PRESENT(l_ice) ) lice = l_ice 602 IF( lice ) THEN 603 ze_s = e_sat_ice( pta ) 604 ELSE 605 ze_s = e_sat( pta ) ! Vapour pressure at saturation (Goff) : 606 END IF 607 q_sat_sclr = reps0*ze_s/(ppa - (1._wp - reps0)*ze_s) 608 END FUNCTION q_sat_sclr 609 !! 610 FUNCTION q_sat_vctr( pta, ppa, l_ice ) 611 REAL(wp), DIMENSION(jpi,jpj) :: q_sat_vctr 612 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute temperature of air [K] 613 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] 614 LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice 615 LOGICAL :: lice 616 INTEGER :: ji, jj 617 !!---------------------------------------------------------------------------------- 618 lice = .FALSE. 619 IF( PRESENT(l_ice) ) lice = l_ice 620 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 621 q_sat_vctr(ji,jj) = q_sat_sclr( pta(ji,jj) , ppa(ji,jj), l_ice=lice ) 622 END_2D 623 END FUNCTION q_sat_vctr 624 !=============================================================================================== 625 626 627 !=============================================================================================== 628 FUNCTION dq_sat_dt_ice_sclr( pta, ppa ) 629 !!--------------------------------------------------------------------------------- 630 !! *** FUNCTION dq_sat_dt_ice_sclr *** 631 !! => d [ q_sat_ice(T) ] / dT 632 !! Analytical exact formulation: double checked!!! 633 !! => DOUBLE-check possible / finite-difference version with "./bin/test_phymbl.x" 634 !!---------------------------------------------------------------------------------- 635 REAL(wp) :: dq_sat_dt_ice_sclr 636 REAL(wp), INTENT(in) :: pta !: absolute temperature of air [K] 637 REAL(wp), INTENT(in) :: ppa !: atmospheric pressure [Pa] 638 REAL(wp) :: ze_s, zde_s_dt, ztmp 639 !!---------------------------------------------------------------------------------- 640 ze_s = e_sat_ice_sclr( pta ) ! Vapour pressure at saturation in presence of ice (Goff) 641 zde_s_dt = de_sat_dt_ice( pta ) 642 ! 643 ztmp = (reps0 - 1._wp)*ze_s + ppa 644 ! 645 dq_sat_dt_ice_sclr = reps0*ppa*zde_s_dt / ( ztmp*ztmp ) 646 ! 647 END FUNCTION dq_sat_dt_ice_sclr 648 !! 649 FUNCTION dq_sat_dt_ice_vctr( pta, ppa ) 650 REAL(wp), DIMENSION(jpi,jpj) :: dq_sat_dt_ice_vctr 651 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute temperature of air [K] 652 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] 653 INTEGER :: ji, jj 654 !!---------------------------------------------------------------------------------- 655 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 656 dq_sat_dt_ice_vctr(ji,jj) = dq_sat_dt_ice_sclr( pta(ji,jj) , ppa(ji,jj) ) 657 END_2D 658 END FUNCTION dq_sat_dt_ice_vctr 659 !=============================================================================================== 660 661 662 !=============================================================================================== 663 FUNCTION q_air_rh(prha, ptak, ppa) 461 664 !!---------------------------------------------------------------------------------- 462 665 !! Specific humidity of air out of Relative Humidity … … 467 670 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prha !: relative humidity [fraction, not %!!!] 468 671 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: air temperature [K] 469 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p slp!: atmospheric pressure [Pa]672 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] 470 673 ! 471 674 INTEGER :: ji, jj ! dummy loop indices … … 474 677 ! 475 678 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 476 477 q_air_rh(ji,jj) = ze*reps0/(pslp(ji,jj) - (1. - reps0)*ze)679 ze = prha(ji,jj)*e_sat_sclr(ptak(ji,jj)) 680 q_air_rh(ji,jj) = ze*reps0/(ppa(ji,jj) - (1. - reps0)*ze) 478 681 END_2D 479 682 ! … … 481 684 482 685 483 SUBROUTINE UPDATE_QNSOL_TAU( pzu, pTs, pqs, pTa, pqa, pust, ptst, pqst, pwnd, pUb, p slp, prlw, &686 SUBROUTINE UPDATE_QNSOL_TAU( pzu, pTs, pqs, pTa, pqa, pust, ptst, pqst, pwnd, pUb, ppa, prlw, & 484 687 & pQns, pTau, & 485 688 & Qlat) … … 499 702 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] 500 703 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] 501 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p slp! sea-level atmospheric pressure [Pa]704 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] 502 705 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prlw ! downwelling longwave radiative flux [W/m^2] 503 706 ! … … 507 710 REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(out) :: Qlat 508 711 ! 509 REAL(wp) :: zdt, zdq, zCd, zCh, zCe, zTs2, zz0, & 510 & zQlat, zQsen, zQlw 712 REAL(wp) :: zdt, zdq, zCd, zCh, zCe, zz0, zQlat, zQsen, zQlw 511 713 INTEGER :: ji, jj ! dummy loop indices 512 714 !!---------------------------------------------------------------------------------- 513 715 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 514 515 zdt = pTa(ji,jj) - pTs(ji,jj) ; zdt = SIGN( MAX(ABS(zdt),1.E-6_wp), zdt ) 516 zdq = pqa(ji,jj) - pqs(ji,jj) ; zdq = SIGN( MAX(ABS(zdq),1.E-9_wp), zdq ) 517 zz0 = pust(ji,jj)/pUb(ji,jj) 518 zCd = zz0*zz0 519 zCh = zz0*ptst(ji,jj)/zdt 520 zCe = zz0*pqst(ji,jj)/zdq 521 522 CALL BULK_FORMULA_SCLR( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & 523 & zCd, zCh, zCe, & 524 & pwnd(ji,jj), pUb(ji,jj), pslp(ji,jj), & 525 & pTau(ji,jj), zQsen, zQlat ) 526 527 zTs2 = pTs(ji,jj)*pTs(ji,jj) 528 zQlw = emiss_w*(prlw(ji,jj) - stefan*zTs2*zTs2) ! Net longwave flux 529 530 pQns(ji,jj) = zQlat + zQsen + zQlw 531 532 IF( PRESENT(Qlat) ) Qlat(ji,jj) = zQlat 716 zdt = pTa(ji,jj) - pTs(ji,jj) ; zdt = SIGN( MAX(ABS(zdt),1.E-6_wp), zdt ) 717 zdq = pqa(ji,jj) - pqs(ji,jj) ; zdq = SIGN( MAX(ABS(zdq),1.E-9_wp), zdq ) 718 zz0 = pust(ji,jj)/pUb(ji,jj) 719 zCd = zz0*zz0 720 zCh = zz0*ptst(ji,jj)/zdt 721 zCe = zz0*pqst(ji,jj)/zdq 722 723 CALL BULK_FORMULA( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), zCd, zCh, zCe, & 724 & pwnd(ji,jj), pUb(ji,jj), ppa(ji,jj), & 725 & pTau(ji,jj), zQsen, zQlat ) 726 727 zQlw = qlw_net_sclr( prlw(ji,jj), pTs(ji,jj) ) ! Net longwave flux 728 729 pQns(ji,jj) = zQlat + zQsen + zQlw 730 731 IF( PRESENT(Qlat) ) Qlat(ji,jj) = zQlat 533 732 END_2D 534 733 END SUBROUTINE UPDATE_QNSOL_TAU … … 537 736 SUBROUTINE BULK_FORMULA_SCLR( pzu, pTs, pqs, pTa, pqa, & 538 737 & pCd, pCh, pCe, & 539 & pwnd, pUb, p slp, &738 & pwnd, pUb, ppa, & 540 739 & pTau, pQsen, pQlat, & 541 740 & pEvap, prhoa, pfact_evap ) … … 551 750 REAL(wp), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] 552 751 REAL(wp), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] 553 REAL(wp), INTENT(in) :: p slp! sea-level atmospheric pressure [Pa]752 REAL(wp), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] 554 753 !! 555 754 REAL(wp), INTENT(out) :: pTau ! module of the wind stress [N/m^2] … … 566 765 zfact_evap = 1._wp 567 766 IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap 568 767 569 768 !! Need ztaa, absolute temperature at pzu (formula to estimate rho_air needs absolute temperature, not the potential temperature "pTa") 570 769 ztaa = pTa ! first guess... 571 770 DO jq = 1, 4 572 zgamma = gamma_moist( 0.5*(ztaa+pTs) , pqa ) ! LOLO: why not "0.5*(pqs+pqa)" rather then "pqa" ???771 zgamma = gamma_moist( 0.5*(ztaa+pTs) , pqa ) !#LB: why not "0.5*(pqs+pqa)" rather then "pqa" ??? 573 772 ztaa = pTa - zgamma*pzu ! Absolute temp. is slightly colder... 574 773 END DO 575 zrho = rho_air(ztaa, pqa, p slp)576 zrho = rho_air(ztaa, pqa, p slp-zrho*grav*pzu) ! taking into account that we are pzu m above the sea level where SLP is given!774 zrho = rho_air(ztaa, pqa, ppa) 775 zrho = rho_air(ztaa, pqa, ppa-zrho*grav*pzu) ! taking into account that we are pzu m above the sea level where SLP is given! 577 776 578 777 zUrho = pUb*MAX(zrho, 1._wp) ! rho*U10 … … 588 787 589 788 END SUBROUTINE BULK_FORMULA_SCLR 590 789 !! 591 790 SUBROUTINE BULK_FORMULA_VCTR( pzu, pTs, pqs, pTa, pqa, & 592 791 & pCd, pCh, pCe, & 593 & pwnd, pUb, p slp, &594 & pTau, pQsen, pQlat, & 595 & pEvap, prhoa, pfact_evap ) 792 & pwnd, pUb, ppa, & 793 & pTau, pQsen, pQlat, & 794 & pEvap, prhoa, pfact_evap ) 596 795 !!---------------------------------------------------------------------------------- 597 796 REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) … … 605 804 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] 606 805 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] 607 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p slp! sea-level atmospheric pressure [Pa]806 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] 608 807 !! 609 808 REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pTau ! module of the wind stress [N/m^2] … … 623 822 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 624 823 625 CALL BULK_FORMULA_SCLR( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & 626 & pCd(ji,jj), pCh(ji,jj), pCe(ji,jj), & 627 & pwnd(ji,jj), pUb(ji,jj), pslp(ji,jj), & 628 & pTau(ji,jj), pQsen(ji,jj), pQlat(ji,jj), & 629 & pEvap=zevap, prhoa=zrho, pfact_evap=zfact_evap ) 630 631 IF( PRESENT(pEvap) ) pEvap(ji,jj) = zevap 632 IF( PRESENT(prhoa) ) prhoa(ji,jj) = zrho 633 824 CALL BULK_FORMULA_SCLR( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & 825 & pCd(ji,jj), pCh(ji,jj), pCe(ji,jj), & 826 & pwnd(ji,jj), pUb(ji,jj), ppa(ji,jj), & 827 & pTau(ji,jj), pQsen(ji,jj), pQlat(ji,jj), & 828 & pEvap=zevap, prhoa=zrho, pfact_evap=zfact_evap ) 829 830 IF( PRESENT(pEvap) ) pEvap(ji,jj) = zevap 831 IF( PRESENT(prhoa) ) prhoa(ji,jj) = zrho 634 832 END_2D 635 833 END SUBROUTINE BULK_FORMULA_VCTR … … 640 838 !! *** FUNCTION alpha_sw_vctr *** 641 839 !! 642 !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface ( i.e. P =~ 101000 Pa)840 !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface (P =~ 1010 hpa) 643 841 !! 644 842 !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) … … 654 852 !! *** FUNCTION alpha_sw_sclr *** 655 853 !! 656 !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface ( i.e. P =~ 101000 Pa)854 !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface (P =~ 1010 hpa) 657 855 !! 658 856 !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) … … 665 863 666 864 865 !=============================================================================================== 866 FUNCTION qlw_net_sclr( pdwlw, pts, l_ice ) 867 !!--------------------------------------------------------------------------------- 868 !! *** FUNCTION qlw_net_sclr *** 869 !! 870 !! ** Purpose : Estimate of the net longwave flux at the surface 871 !!---------------------------------------------------------------------------------- 872 REAL(wp) :: qlw_net_sclr 873 REAL(wp), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] 874 REAL(wp), INTENT(in) :: pts !: surface temperature [K] 875 LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice 876 REAL(wp) :: zemiss, zt2 877 LOGICAL :: lice 878 !!---------------------------------------------------------------------------------- 879 lice = .FALSE. 880 IF( PRESENT(l_ice) ) lice = l_ice 881 IF( lice ) THEN 882 zemiss = emiss_i 883 ELSE 884 zemiss = emiss_w 885 END IF 886 zt2 = pts*pts 887 qlw_net_sclr = zemiss*( pdwlw - stefan*zt2*zt2) ! zemiss used both as the IR albedo and IR emissivity... 888 END FUNCTION qlw_net_sclr 889 !! 890 FUNCTION qlw_net_vctr( pdwlw, pts, l_ice ) 891 REAL(wp), DIMENSION(jpi,jpj) :: qlw_net_vctr 892 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] 893 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pts !: surface temperature [K] 894 LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice 895 LOGICAL :: lice 896 INTEGER :: ji, jj 897 !!---------------------------------------------------------------------------------- 898 lice = .FALSE. 899 IF( PRESENT(l_ice) ) lice = l_ice 900 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 901 qlw_net_vctr(ji,jj) = qlw_net_sclr( pdwlw(ji,jj) , pts(ji,jj), l_ice=lice ) 902 END_2D 903 END FUNCTION qlw_net_vctr 904 !=============================================================================================== 905 906 FUNCTION z0_from_Cd( pzu, pCd, ppsi ) 907 REAL(wp), DIMENSION(jpi,jpj) :: z0_from_Cd !: roughness length [m] 908 REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] 909 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: (neutral or non-neutral) drag coefficient [] 910 REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] 911 !! 912 !! If pCd is the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given 913 !! If pCd is the drag coefficient (in stable or unstable conditions) then pssi must be provided 914 !!---------------------------------------------------------------------------------- 915 IF( PRESENT(ppsi) ) THEN 916 !! Cd provided is the actual Cd (not the neutral-stability CdN) : 917 z0_from_Cd = pzu * EXP( - ( vkarmn/SQRT(pCd(:,:)) + ppsi(:,:) ) ) !LB: ok, double-checked! 918 ELSE 919 !! Cd provided is the neutral-stability Cd, aka CdN : 920 z0_from_Cd = pzu * EXP( - vkarmn/SQRT(pCd(:,:)) ) !LB: ok, double-checked! 921 END IF 922 END FUNCTION z0_from_Cd 923 924 FUNCTION Cd_from_z0( pzu, pz0, ppsi ) 925 REAL(wp), DIMENSION(jpi,jpj) :: Cd_from_z0 !: (neutral or non-neutral) drag coefficient [] 926 REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] 927 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length [m] 928 REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] 929 !! 930 !! If we want to return the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given 931 !! If we want to return the stability-corrected Cd (i.e. in stable or unstable conditions) then pssi must be provided 932 !!---------------------------------------------------------------------------------- 933 IF( PRESENT(ppsi) ) THEN 934 !! The Cd we return is the actual Cd (not the neutral-stability CdN) : 935 Cd_from_z0 = 1._wp / ( LOG( pzu / pz0(:,:) ) - ppsi(:,:) ) 936 ELSE 937 !! The Cd we return is the neutral-stability Cd, aka CdN : 938 Cd_from_z0 = 1._wp / LOG( pzu / pz0(:,:) ) 939 END IF 940 Cd_from_z0 = vkarmn2 * Cd_from_z0 * Cd_from_z0 941 END FUNCTION Cd_from_z0 942 943 944 FUNCTION f_m_louis_sclr( pzu, pRib, pCdn, pz0 ) 945 !!---------------------------------------------------------------------------------- 946 !! Stability correction function for MOMENTUM 947 !! Louis (1979) 948 !!---------------------------------------------------------------------------------- 949 REAL(wp) :: f_m_louis_sclr ! term "f_m" in Eq.(6) when option "Louis" rather than "Psi(zeta) is chosen, Lupkes & Gryanik (2015), 950 REAL(wp), INTENT(in) :: pzu ! reference height (height for pwnd) [m] 951 REAL(wp), INTENT(in) :: pRib ! Bulk Richardson number 952 REAL(wp), INTENT(in) :: pCdn ! neutral drag coefficient 953 REAL(wp), INTENT(in) :: pz0 ! roughness length [m] 954 !!---------------------------------------------------------------------------------- 955 REAL(wp) :: ztu, zts, zstab 956 !!---------------------------------------------------------------------------------- 957 zstab = 0.5 + SIGN(0.5_wp, pRib) ; ! Unstable (Ri<0) => zstab = 0 | Stable (Ri>0) => zstab = 1 958 ! 959 ztu = pRib / ( 1._wp + 3._wp * rc2_louis * pCdn * SQRT( ABS( -pRib * ( pzu / pz0 + 1._wp) ) ) ) ! ABS is just here for when it's stable conditions and ztu is not used anyways 960 zts = pRib / SQRT( ABS( 1._wp + pRib ) ) ! ABS is just here for when it's UNstable conditions and zts is not used anyways 961 ! 962 f_m_louis_sclr = (1._wp - zstab) * ( 1._wp - ram_louis * ztu ) & ! Unstable Eq.(A6) 963 & + zstab * 1._wp / ( 1._wp + ram_louis * zts ) ! Stable Eq.(A7) 964 ! 965 END FUNCTION f_m_louis_sclr 966 !! 967 FUNCTION f_m_louis_vctr( pzu, pRib, pCdn, pz0 ) 968 REAL(wp), DIMENSION(jpi,jpj) :: f_m_louis_vctr 969 REAL(wp), INTENT(in) :: pzu 970 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRib 971 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCdn 972 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 973 INTEGER :: ji, jj 974 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 975 f_m_louis_vctr(ji,jj) = f_m_louis_sclr( pzu, pRib(ji,jj), pCdn(ji,jj), pz0(ji,jj) ) 976 END_2D 977 END FUNCTION f_m_louis_vctr 978 979 980 FUNCTION f_h_louis_sclr( pzu, pRib, pChn, pz0 ) 981 !!---------------------------------------------------------------------------------- 982 !! Stability correction function for HEAT 983 !! Louis (1979) 984 !!---------------------------------------------------------------------------------- 985 REAL(wp) :: f_h_louis_sclr ! term "f_h" in Eq.(6) when option "Louis" rather than "Psi(zeta) is chosen, Lupkes & Gryanik (2015), 986 REAL(wp), INTENT(in) :: pzu ! reference height (height for pwnd) [m] 987 REAL(wp), INTENT(in) :: pRib ! Bulk Richardson number 988 REAL(wp), INTENT(in) :: pChn ! neutral heat transfer coefficient 989 REAL(wp), INTENT(in) :: pz0 ! roughness length [m] 990 !!---------------------------------------------------------------------------------- 991 REAL(wp) :: ztu, zts, zstab 992 !!---------------------------------------------------------------------------------- 993 zstab = 0.5 + SIGN(0.5_wp, pRib) ; ! Unstable (Ri<0) => zstab = 0 | Stable (Ri>0) => zstab = 1 994 ! 995 ztu = pRib / ( 1._wp + 3._wp * rc2_louis * pChn * SQRT( ABS(-pRib * ( pzu / pz0 + 1._wp) ) ) ) 996 zts = pRib / SQRT( ABS( 1._wp + pRib ) ) 997 ! 998 f_h_louis_sclr = (1._wp - zstab) * ( 1._wp - rah_louis * ztu ) & ! Unstable Eq.(A6) 999 & + zstab * 1._wp / ( 1._wp + rah_louis * zts ) ! Stable Eq.(A7) !#LB: in paper it's "ram_louis" and not "rah_louis" typo or what???? 1000 ! 1001 END FUNCTION f_h_louis_sclr 1002 !! 1003 FUNCTION f_h_louis_vctr( pzu, pRib, pChn, pz0 ) 1004 REAL(wp), DIMENSION(jpi,jpj) :: f_h_louis_vctr 1005 REAL(wp), INTENT(in) :: pzu 1006 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRib 1007 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pChn 1008 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 1009 INTEGER :: ji, jj 1010 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 1011 f_h_louis_vctr(ji,jj) = f_h_louis_sclr( pzu, pRib(ji,jj), pChn(ji,jj), pz0(ji,jj) ) 1012 END_2D 1013 END FUNCTION f_h_louis_vctr 1014 1015 FUNCTION UN10_from_ustar( pzu, pUzu, pus, ppsi ) 1016 !!---------------------------------------------------------------------------------- 1017 !! Provides the neutral-stability wind speed at 10 m 1018 !!---------------------------------------------------------------------------------- 1019 REAL(wp), DIMENSION(jpi,jpj) :: UN10_from_ustar !: neutral stability wind speed at 10m [m/s] 1020 REAL(wp), INTENT(in) :: pzu !: measurement heigh of wind speed [m] 1021 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUzu !: bulk wind speed at height pzu m [m/s] 1022 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: friction velocity [m/s] 1023 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] 1024 !!---------------------------------------------------------------------------------- 1025 UN10_from_ustar(:,:) = pUzu(:,:) - pus(:,:)/vkarmn * ( LOG(pzu/10._wp) - ppsi(:,:) ) 1026 !! 1027 END FUNCTION UN10_from_ustar 1028 1029 1030 FUNCTION UN10_from_CD( pzu, pUb, pCd, ppsi ) 1031 !!---------------------------------------------------------------------------------- 1032 !! Provides the neutral-stability wind speed at 10 m 1033 !!---------------------------------------------------------------------------------- 1034 REAL(wp), DIMENSION(jpi,jpj) :: UN10_from_CD !: [m/s] 1035 REAL(wp), INTENT(in) :: pzu !: measurement heigh of bulk wind speed 1036 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb !: bulk wind speed at height pzu m [m/s] 1037 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: drag coefficient 1038 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] 1039 !!---------------------------------------------------------------------------------- 1040 !! Reminder: UN10 = u*/vkarmn * log(10/z0) 1041 !! and: u* = sqrt(Cd) * Ub 1042 !! u*/vkarmn * log( 10 / z0 ) 1043 UN10_from_CD(:,:) = SQRT(pCd(:,:))*pUb/vkarmn * LOG( 10._wp / z0_from_Cd( pzu, pCd(:,:), ppsi=ppsi(:,:) ) ) 1044 !! 1045 END FUNCTION UN10_from_CD 1046 1047 1048 FUNCTION z0tq_LKB( iflag, pRer, pz0 ) 1049 !!--------------------------------------------------------------------------------- 1050 !! *** FUNCTION z0tq_LKB *** 1051 !! 1052 !! ** Purpose : returns the "temperature/humidity roughness lengths" 1053 !! * iflag==1 => temperature => returns: z_{0t} 1054 !! * iflag==2 => humidity => returns: z_{0q} 1055 !! from roughness reynold number "pRer" (i.e. [z_0 u*]/Nu_{air}) 1056 !! between 0 and 1000. Out of range "pRer" indicated by prt=-999. 1057 !! and roughness length (for momentum) 1058 !! 1059 !! Based on Liu et al. (1979) JAS 36 1722-1723s 1060 !! 1061 !! Note: this is what is used into COARE 2.5 to estimate z_{0t} and z_{0q} 1062 !! 1063 !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) 1064 !!---------------------------------------------------------------------------------- 1065 REAL(wp), DIMENSION(jpi,jpj) :: z0tq_LKB 1066 INTEGER, INTENT(in) :: iflag !: 1 => dealing with temperature; 2 => dealing with humidity 1067 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRer !: roughness Reynolds number [z_0 u*]/Nu_{air} 1068 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length (for momentum) [m] 1069 !------------------------------------------------------------------- 1070 ! Scalar Re_r relation from Liu et al. 1071 REAL(wp), DIMENSION(8,2), PARAMETER :: & 1072 & XA = (/ 0.177, 1.376, 1.026, 1.625, 4.661, 34.904, 1667.19, 5.88e5, & 1073 & 0.292, 1.808, 1.393, 1.956, 4.994, 30.709, 1448.68, 2.98e5 /) 1074 !! 1075 REAL(wp), DIMENSION(8,2), PARAMETER :: & 1076 & XB = (/ 0., 0.929, -0.599, -1.018, -1.475, -2.067, -2.907, -3.935, & 1077 & 0., 0.826, -0.528, -0.870, -1.297, -1.845, -2.682, -3.616 /) 1078 !! 1079 REAL(wp), DIMENSION(0:8), PARAMETER :: & 1080 & XRAN = (/ 0., 0.11, 0.825, 3.0, 10.0, 30.0, 100., 300., 1000. /) 1081 !------------------------------------------------------------------- 1082 ! 1083 !------------------------------------------------------------------- 1084 ! Scalar Re_r relation from Moana Wave data. 1085 ! 1086 ! real*8 A(9,2),B(9,2),RAN(9),pRer,prt 1087 ! integer iflag 1088 ! DATA A/0.177,2.7e3,1.03,1.026,1.625,4.661,34.904,1667.19,5.88E5, 1089 ! & 0.292,3.7e3,1.4,1.393,1.956,4.994,30.709,1448.68,2.98E5/ 1090 ! DATA B/0.,4.28,0,-0.599,-1.018,-1.475,-2.067,-2.907,-3.935, 1091 ! & 0.,4.28,0,-0.528,-0.870,-1.297,-1.845,-2.682,-3.616/ 1092 ! DATA RAN/0.11,.16,1.00,3.0,10.0,30.0,100.,300.,1000./ 1093 !------------------------------------------------------------------- 1094 1095 LOGICAL :: lfound=.FALSE. 1096 REAL(wp) :: zrr 1097 INTEGER :: ji, jj, jm 1098 1099 z0tq_LKB(:,:) = -999._wp 1100 1101 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 1102 1103 zrr = pRer(ji,jj) 1104 lfound = .FALSE. 1105 1106 IF( (zrr > 0.).AND.(zrr < 1000.) ) THEN 1107 jm = 0 1108 DO WHILE ( .NOT. lfound ) 1109 jm = jm + 1 1110 lfound = ( (zrr > XRAN(jm-1)) .AND. (zrr <= XRAN(jm)) ) 1111 END DO 1112 1113 z0tq_LKB(ji,jj) = XA(jm,iflag)*zrr**XB(jm,iflag) * pz0(ji,jj)/zrr 1114 1115 END IF 1116 1117 END_2D 1118 1119 z0tq_LKB(:,:) = MIN( MAX(ABS(z0tq_LKB(:,:)), 1.E-9) , 0.05_wp ) 1120 1121 END FUNCTION z0tq_LKB 1122 667 1123 668 1124 !!====================================================================== 669 END MODULE sbc blk_phy1125 END MODULE sbc_phy -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/SBC/sbcblk.F90
r13501 r13655 30 30 !! blk_ice_2 : provide the heat and mass fluxes at air-ice interface 31 31 !! blk_ice_qcn : provide ice surface temperature and snow/ice conduction flux (emulating conduction flux) 32 !! Cdn10_Lupkes2012 : Lupkes et al. (2012) air-ice drag33 !! Cdn10_Lupkes2015 : Lupkes et al. (2015) air-ice drag34 32 !!---------------------------------------------------------------------- 35 33 USE oce ! ocean dynamics and tracers … … 41 39 USE sbcdcy ! surface boundary condition: diurnal cycle 42 40 USE sbcwave , ONLY : cdn_wave ! wave module 43 USE sbc_ice ! Surface boundary condition: ice fields44 41 USE lib_fortran ! to use key_nosignedzero 42 ! 45 43 #if defined key_si3 44 USE sbc_ice ! Surface boundary condition: ice fields #LB? ok to be in 'key_si3' ??? 46 45 USE ice , ONLY : u_ice, v_ice, jpl, a_i_b, at_i_b, t_su, rn_cnd_s, hfx_err_dif, nn_qtrice 47 46 USE icevar ! for CALL ice_var_snwblow 48 #endif 49 USE sbcblk_algo_ncar ! => turb_ncar : NCAR - CORE (Large & Yeager, 2009) 47 USE sbcblk_algo_ice_lu12 48 USE sbcblk_algo_ice_lg15 49 #endif 50 USE sbcblk_algo_ncar ! => turb_ncar : NCAR - (formerly known as CORE, Large & Yeager, 2009) 50 51 USE sbcblk_algo_coare3p0 ! => turb_coare3p0 : COAREv3.0 (Fairall et al. 2003) 51 52 USE sbcblk_algo_coare3p6 ! => turb_coare3p6 : COAREv3.6 (Fairall et al. 2018 + Edson et al. 2013) 52 53 USE sbcblk_algo_ecmwf ! => turb_ecmwf : ECMWF (IFS cycle 45r1) 54 USE sbcblk_algo_andreas ! => turb_andreas : Andreas et al. 2015 55 ! 56 53 57 ! 54 58 USE iom ! I/O manager library … … 58 62 USE prtctl ! Print control 59 63 60 USE sbc blk_phy! a catalog of functions for physical/meteorological parameters in the marine boundary layer, rho_air, q_sat, etc...64 USE sbc_phy ! a catalog of functions for physical/meteorological parameters in the marine boundary layer, rho_air, q_sat, etc... 61 65 62 66 … … 100 104 LOGICAL :: ln_COARE_3p6 ! "COARE 3.6" algorithm (Edson et al. 2013) 101 105 LOGICAL :: ln_ECMWF ! "ECMWF" algorithm (IFS cycle 45r1) 106 LOGICAL :: ln_ANDREAS ! "ANDREAS" algorithm (Andreas et al. 2015) 102 107 ! 103 LOGICAL :: ln_Cd_L12 ! ice-atm drag = F( ice concentration ) (Lupkes et al. JGR2012) 104 LOGICAL :: ln_Cd_L15 ! ice-atm drag = F( ice concentration, atmospheric stability ) (Lupkes et al. JGR2015) 108 !#LB: 109 LOGICAL :: ln_Cx_ice_cst ! use constant ice-air bulk transfer coefficients (value given in namelist's rn_Cd_i, rn_Ce_i & rn_Ch_i) 110 REAL(wp) :: rn_Cd_i, rn_Ce_i, rn_Ch_i 111 LOGICAL :: ln_Cx_ice_LU12 ! ice-atm drag = F( ice concentration ) (Lupkes et al. JGR2012) 112 LOGICAL :: ln_Cx_ice_LG15 ! ice-atm drag = F( ice concentration, atmospheric stability ) (Lupkes et al. JGR2015) 113 !#LB. 105 114 ! 106 115 LOGICAL :: ln_crt_fbk ! Add surface current feedback to the wind stress computation (Renault et al. 2020) 107 116 REAL(wp) :: rn_stau_a ! Alpha and Beta coefficients of Renault et al. 2020, eq. 10: Stau = Alpha * Wnd + Beta 108 REAL(wp) :: rn_stau_b ! 117 REAL(wp) :: rn_stau_b ! 109 118 ! 110 119 REAL(wp) :: rn_pfac ! multiplication factor for precipitation … … 113 122 REAL(wp) :: rn_zu ! z(u) : height of wind measurements 114 123 ! 115 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: Cdn_oce, Chn_oce, Cen_oce ! neutral coeffs over ocean (L15 bulk scheme and ABL) 116 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: Cd_ice , Ch_ice , Ce_ice ! transfert coefficients over ice 117 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: t_zu, q_zu ! air temp. and spec. hum. at wind speed height (L15 bulk scheme) 124 INTEGER :: nn_iter_algo ! Number of iterations in bulk param. algo ("stable ABL + weak wind" requires more) 125 126 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: theta_zu, q_zu ! air temp. and spec. hum. at wind speed height (L15 bulk scheme) 127 128 #if defined key_si3 129 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: Cd_ice , Ch_ice , Ce_ice !#LB transfert coefficients over ice 130 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: theta_zu_i, q_zu_i !#LB fixme ! air temp. and spec. hum. over ice at wind speed height (L15 bulk scheme) 131 #endif 132 118 133 119 134 LOGICAL :: ln_skin_cs ! use the cool-skin (only available in ECMWF and COARE algorithms) !LB … … 136 151 INTEGER, PARAMETER :: np_COARE_3p6 = 3 ! "COARE 3.6" algorithm (Edson et al. 2013) 137 152 INTEGER, PARAMETER :: np_ECMWF = 4 ! "ECMWF" algorithm (IFS cycle 45r1) 153 INTEGER, PARAMETER :: np_ANDREAS = 5 ! "ANDREAS" algorithm (Andreas et al. 2015) 154 155 !#LB: 156 #if defined key_si3 157 ! Same, over sea-ice: 158 INTEGER :: nblk_ice ! choice of the bulk algorithm 159 ! ! associated indices: 160 INTEGER, PARAMETER :: np_ice_cst = 1 ! constant transfer coefficients 161 INTEGER, PARAMETER :: np_ice_lu12 = 2 ! Lupkes, 2012 162 INTEGER, PARAMETER :: np_ice_lg15 = 3 ! Lupkes & Gryanik, 2015 163 #endif 164 !LB. 165 166 138 167 139 168 !! * Substitutions … … 150 179 !! *** ROUTINE sbc_blk_alloc *** 151 180 !!------------------------------------------------------------------- 152 ALLOCATE( t_zu(jpi,jpj) , q_zu(jpi,jpj) , & 153 & Cdn_oce(jpi,jpj), Chn_oce(jpi,jpj), Cen_oce(jpi,jpj), & 154 & Cd_ice (jpi,jpj), Ch_ice (jpi,jpj), Ce_ice (jpi,jpj), STAT=sbc_blk_alloc ) 155 ! 181 ALLOCATE( theta_zu(jpi,jpj), q_zu(jpi,jpj), STAT=sbc_blk_alloc ) 156 182 CALL mpp_sum ( 'sbcblk', sbc_blk_alloc ) 157 183 IF( sbc_blk_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk_alloc: failed to allocate arrays' ) 158 184 END FUNCTION sbc_blk_alloc 185 186 #if defined key_si3 187 INTEGER FUNCTION sbc_blk_ice_alloc() 188 !!------------------------------------------------------------------- 189 !! *** ROUTINE sbc_blk_ice_alloc *** 190 !!------------------------------------------------------------------- 191 ALLOCATE( Cd_ice (jpi,jpj), Ch_ice (jpi,jpj), Ce_ice (jpi,jpj), & 192 & theta_zu_i(jpi,jpj), q_zu_i(jpi,jpj), STAT=sbc_blk_ice_alloc ) 193 CALL mpp_sum ( 'sbcblk', sbc_blk_ice_alloc ) 194 IF( sbc_blk_ice_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk_ice_alloc: failed to allocate arrays' ) 195 END FUNCTION sbc_blk_ice_alloc 196 #endif 159 197 160 198 … … 178 216 TYPE(FLD_N) :: sn_cc, sn_hpgi, sn_hpgj ! " " 179 217 INTEGER :: ipka ! number of levels in the atmospheric variable 180 NAMELIST/namsbc_blk/ sn_wndi, sn_wndj, sn_humi, sn_qsr, sn_qlw , & ! input fields 181 & sn_tair, sn_prec, sn_snow, sn_slp, sn_uoatm, sn_voatm, & 182 & sn_cc, sn_hpgi, sn_hpgj, & 183 & ln_NCAR, ln_COARE_3p0, ln_COARE_3p6, ln_ECMWF, & ! bulk algorithm 184 & cn_dir , rn_zqt, rn_zu, & 185 & rn_pfac, rn_efac, ln_Cd_L12, ln_Cd_L15, ln_tpot, & 186 & ln_crt_fbk, rn_stau_a, rn_stau_b, & ! current feedback 187 & ln_skin_cs, ln_skin_wl, ln_humi_sph, ln_humi_dpt, ln_humi_rlh ! cool-skin / warm-layer !LB 218 NAMELIST/namsbc_blk/ ln_NCAR, ln_COARE_3p0, ln_COARE_3p6, ln_ECMWF, ln_ANDREAS, & ! bulk algorithm 219 & rn_zqt, rn_zu, nn_iter_algo, ln_skin_cs, ln_skin_wl, & 220 & rn_pfac, rn_efac, & 221 & ln_crt_fbk, rn_stau_a, rn_stau_b, & ! current feedback 222 & ln_humi_sph, ln_humi_dpt, ln_humi_rlh, ln_tpot, & 223 & ln_Cx_ice_cst, rn_Cd_i, rn_Ce_i, rn_Ch_i, & 224 & ln_Cx_ice_LU12, ln_Cx_ice_LG15, & 225 & cn_dir, & 226 & sn_wndi, sn_wndj, sn_qsr, sn_qlw , & ! input fields 227 & sn_tair, sn_humi, sn_prec, sn_snow, sn_slp, & 228 & sn_uoatm, sn_voatm, sn_cc, sn_hpgi, sn_hpgj 229 230 ! cool-skin / warm-layer !LB 188 231 !!--------------------------------------------------------------------- 189 232 ! 190 233 ! ! allocate sbc_blk_core array 191 IF( sbc_blk_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk : unable to allocate standard arrays' ) 234 IF( sbc_blk_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk : unable to allocate standard arrays' ) 235 ! 236 #if defined key_si3 237 IF( sbc_blk_ice_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk : unable to allocate standard ice arrays' ) 238 #endif 192 239 ! 193 240 ! !** read bulk namelist … … 215 262 nblk = np_ECMWF ; ioptio = ioptio + 1 216 263 ENDIF 264 IF( ln_ANDREAS ) THEN 265 nblk = np_ANDREAS ; ioptio = ioptio + 1 266 ENDIF 217 267 IF( ioptio /= 1 ) CALL ctl_stop( 'sbc_blk_init: Choose one and only one bulk algorithm' ) 218 268 … … 222 272 IF( ln_NCAR ) & 223 273 & CALL ctl_stop( 'sbc_blk_init: Cool-skin/warm-layer param. not compatible with NCAR algorithm' ) 274 IF( ln_ANDREAS ) & 275 & CALL ctl_stop( 'sbc_blk_init: Cool-skin/warm-layer param. not compatible with ANDREAS algorithm' ) 224 276 IF( nn_fsbc /= 1 ) & 225 277 & CALL ctl_stop( 'sbc_blk_init: Please set "nn_fsbc" to 1 when using cool-skin/warm-layer param.') … … 254 306 ENDIF 255 307 ENDIF 308 309 #if defined key_si3 310 ioptio = 0 311 IF( ln_Cx_ice_cst ) THEN 312 nblk_ice = np_ice_cst ; ioptio = ioptio + 1 313 ENDIF 314 IF( ln_Cx_ice_LU12 ) THEN 315 nblk_ice = np_ice_lu12 ; ioptio = ioptio + 1 316 ENDIF 317 IF( ln_Cx_ice_LG15 ) THEN 318 nblk_ice = np_ice_lg15 ; ioptio = ioptio + 1 319 ENDIF 320 IF( ioptio /= 1 ) CALL ctl_stop( 'sbc_blk_init: Choose one and only one ice-atm bulk algorithm' ) 321 #endif 322 323 256 324 ! !* set the bulk structure 257 325 ! !- store namelist information in an array … … 310 378 ! 311 379 IF( sf(jfpr)%freqh > 0. .AND. MOD( NINT(3600. * sf(jfpr)%freqh), nn_fsbc * NINT(rn_Dt) ) /= 0 ) & 312 & CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rn_Dt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.', &313 & ' This is not ideal. You should consider changing either rn_Dt or nn_fsbc value...' )380 & CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rn_Dt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.', & 381 & ' This is not ideal. You should consider changing either rn_Dt or nn_fsbc value...' ) 314 382 ENDIF 315 383 END DO … … 321 389 !drag coefficient read from wave model definable only with mfs bulk formulae and core 322 390 ELSEIF(ln_cdgw .AND. .NOT. ln_NCAR ) THEN 323 CALL ctl_stop( 'drag coefficient read from wave model definable only with NCAR and COREbulk formulae')391 CALL ctl_stop( 'drag coefficient read from wave model definable only with NCAR bulk formulae') 324 392 ELSEIF(ln_stcor .AND. .NOT. ln_sdw) THEN 325 393 CALL ctl_stop( 'Stokes-Coriolis term calculated only if activated Stokes Drift ln_sdw=T') … … 341 409 ENDIF 342 410 ! 343 ! set transfer coefficients to default sea-ice values344 Cd_ice(:,:) = rCd_ice345 Ch_ice(:,:) = rCd_ice346 Ce_ice(:,:) = rCd_ice347 411 ! 348 412 IF(lwp) THEN !** Control print … … 350 414 WRITE(numout,*) !* namelist 351 415 WRITE(numout,*) ' Namelist namsbc_blk (other than data information):' 352 WRITE(numout,*) ' "NCAR" algorithm (Large and Yeager 2008) ln_NCAR = ', ln_NCAR416 WRITE(numout,*) ' "NCAR" algorithm (Large and Yeager 2008) ln_NCAR = ', ln_NCAR 353 417 WRITE(numout,*) ' "COARE 3.0" algorithm (Fairall et al. 2003) ln_COARE_3p0 = ', ln_COARE_3p0 354 WRITE(numout,*) ' "COARE 3.6" algorithm (Fairall 2018 + Edson al 2013)ln_COARE_3p6 = ', ln_COARE_3p6 355 WRITE(numout,*) ' "ECMWF" algorithm (IFS cycle 45r1) ln_ECMWF = ', ln_ECMWF 418 WRITE(numout,*) ' "COARE 3.6" algorithm (Fairall 2018 + Edson al 2013) ln_COARE_3p6 = ', ln_COARE_3p6 419 WRITE(numout,*) ' "ECMWF" algorithm (IFS cycle 45r1) ln_ECMWF = ', ln_ECMWF 420 WRITE(numout,*) ' "ANDREAS" algorithm (Andreas et al. 2015) ln_ANDREAS = ', ln_ANDREAS 356 421 WRITE(numout,*) ' Air temperature and humidity reference height (m) rn_zqt = ', rn_zqt 357 422 WRITE(numout,*) ' Wind vector reference height (m) rn_zu = ', rn_zu … … 359 424 WRITE(numout,*) ' factor applied on evaporation rn_efac = ', rn_efac 360 425 WRITE(numout,*) ' (form absolute (=0) to relative winds(=1))' 361 WRITE(numout,*) ' use ice-atm drag from Lupkes2012 ln_Cd_L12 = ', ln_Cd_L12362 WRITE(numout,*) ' use ice-atm drag from Lupkes2015 ln_Cd_L15 = ', ln_Cd_L15363 426 WRITE(numout,*) ' use surface current feedback on wind stress ln_crt_fbk = ', ln_crt_fbk 364 427 IF(ln_crt_fbk) THEN 365 WRITE(numout,*) ' Renault et al. 2020, eq. 10: Stau = Alpha * Wnd + Beta'366 WRITE(numout,*) ' Alpha rn_stau_a = ', rn_stau_a367 WRITE(numout,*) ' Beta rn_stau_b = ', rn_stau_b428 WRITE(numout,*) ' Renault et al. 2020, eq. 10: Stau = Alpha * Wnd + Beta' 429 WRITE(numout,*) ' Alpha rn_stau_a = ', rn_stau_a 430 WRITE(numout,*) ' Beta rn_stau_b = ', rn_stau_b 368 431 ENDIF 369 432 ! … … 374 437 CASE( np_COARE_3p6 ) ; WRITE(numout,*) ' ==>>> "COARE 3.6" algorithm (Fairall 2018+Edson et al. 2013)' 375 438 CASE( np_ECMWF ) ; WRITE(numout,*) ' ==>>> "ECMWF" algorithm (IFS cycle 45r1)' 439 CASE( np_ANDREAS ) ; WRITE(numout,*) ' ==>>> "ANDREAS" algorithm (Andreas et al. 2015)' 376 440 END SELECT 377 441 ! … … 386 450 CASE( np_humi_rlh ) ; WRITE(numout,*) ' ==>>> air humidity is RELATIVE HUMIDITY [%]' 387 451 END SELECT 452 ! 453 !#LB: 454 #if defined key_si3 455 IF( nn_ice > 0 ) THEN 456 WRITE(numout,*) 457 WRITE(numout,*) ' use constant ice-atm bulk transfer coeff. ln_Cx_ice_cst = ', ln_Cx_ice_cst 458 WRITE(numout,*) ' use ice-atm bulk coeff. from Lupkes, 2012 ln_Cx_ice_LU12 = ', ln_Cx_ice_LU12 459 WRITE(numout,*) ' use ice-atm bulk coeff. from Lupkes & Gryanik, 2015 ln_Cx_ice_LG15 = ', ln_Cx_ice_LG15 460 ENDIF 461 WRITE(numout,*) 462 SELECT CASE( nblk_ice ) !* Print the choice of bulk algorithm 463 CASE( np_ice_cst ) 464 WRITE(numout,*) ' ==>>> Constant bulk transfer coefficients over sea-ice:' 465 WRITE(numout,*) ' => Cd_ice, Ce_ice, Ch_ice =', REAL(rn_Cd_i,4), REAL(rn_Ce_i,4), REAL(rn_Ch_i,4) 466 IF( (rn_Cd_i<0._wp).OR.(rn_Cd_i>1.E-2_wp).OR.(rn_Ce_i<0._wp).OR.(rn_Ce_i>1.E-2_wp).OR.(rn_Ch_i<0._wp).OR.(rn_Ch_i>1.E-2_wp) ) & 467 & CALL ctl_stop( 'Be realistic in your pick of Cd_ice, Ce_ice & Ch_ice ! (0 < Cx < 1.E-2)') 468 CASE( np_ice_lu12 ) ; WRITE(numout,*) ' ==>>> bulk algo over ice: Lupkes et al, 2012' 469 CASE( np_ice_lg15 ) ; WRITE(numout,*) ' ==>>> bulk algo over ice: Lupkes & Gryanik, 2015' 470 END SELECT 471 #endif 472 !#LB. 388 473 ! 389 474 ENDIF … … 428 513 INTEGER, INTENT(in) :: kt ! ocean time step 429 514 !!---------------------------------------------------------------------- 430 REAL(wp), DIMENSION(jpi,jpj) :: zssq, zcd_du, zsen, z evp515 REAL(wp), DIMENSION(jpi,jpj) :: zssq, zcd_du, zsen, zlat, zevp 431 516 REAL(wp) :: ztmp 432 517 !!---------------------------------------------------------------------- … … 465 550 ! ! compute the surface ocean fluxes using bulk formulea 466 551 IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 552 553 ! Specific humidity of air at z=rn_zqt ! 554 SELECT CASE( nhumi ) 555 CASE( np_humi_sph ) 556 q_air_zt(:,:) = sf(jp_humi )%fnow(:,:,1) ! what we read in file is already a spec. humidity! 557 CASE( np_humi_dpt ) 558 IF((kt==nit000).AND.lwp) WRITE(numout,*) ' *** sbc_blk() => computing q_air out of dew-point and P !' 559 q_air_zt(:,:) = q_sat( sf(jp_humi )%fnow(:,:,1), sf(jp_slp )%fnow(:,:,1) ) 560 CASE( np_humi_rlh ) 561 IF((kt==nit000).AND.lwp) WRITE(numout,*) ' *** sbc_blk() => computing q_air out of RH, t_air and slp !' !LBrm 562 q_air_zt(:,:) = q_air_rh( 0.01_wp*sf(jp_humi )%fnow(:,:,1), & 563 & sf(jp_tair )%fnow(:,:,1), sf(jp_slp )%fnow(:,:,1) ) !#LB: 0.01 => RH is % percent in file 564 END SELECT 565 566 ! POTENTIAL temperature of air at z=rn_zqt 567 ! based on adiabatic lapse-rate (see Josey, Gulev & Yu, 2013) / doi=10.1016/B978-0-12-391851-2.00005-2 568 ! (most reanalysis products provide absolute temp., not potential temp.) 569 IF( ln_tpot ) THEN 570 ! temperature read into file is ABSOLUTE temperature (that's the case for ECMWF products for example...) 571 IF((kt==nit000).AND.lwp) WRITE(numout,*) ' *** sbc_blk() => computing air POTENTIAL temperature out of ABSOLUTE temperature!' 572 theta_air_zt(:,:) = sf(jp_tair )%fnow(:,:,1) + gamma_moist( sf(jp_tair )%fnow(:,:,1), q_air_zt(:,:) ) * rn_zqt 573 ELSE 574 ! temperature read into file is already potential temperature 575 theta_air_zt(:,:) = sf(jp_tair )%fnow(:,:,1) 576 ENDIF 577 ! 467 578 CALL blk_oce_1( kt, sf(jp_wndi )%fnow(:,:,1), sf(jp_wndj )%fnow(:,:,1), & ! <<= in 468 & sf(jp_tair )%fnow(:,:,1), sf(jp_humi )%fnow(:,:,1),& ! <<= in579 & theta_air_zt(:,:), q_air_zt(:,:), & ! <<= in 469 580 & sf(jp_slp )%fnow(:,:,1), sst_m, ssu_m, ssv_m, & ! <<= in 470 581 & sf(jp_uoatm)%fnow(:,:,1), sf(jp_voatm)%fnow(:,:,1), & ! <<= in 471 582 & sf(jp_qsr )%fnow(:,:,1), sf(jp_qlw )%fnow(:,:,1), & ! <<= in (wl/cs) 472 & tsk_m, zssq, zcd_du, zsen, z evp )! =>> out473 474 CALL blk_oce_2( sf(jp_tair )%fnow(:,:,1), sf(jp_qsr )%fnow(:,:,1),& ! <<= in583 & tsk_m, zssq, zcd_du, zsen, zlat, zevp ) ! =>> out 584 585 CALL blk_oce_2( theta_air_zt(:,:), & ! <<= in 475 586 & sf(jp_qlw )%fnow(:,:,1), sf(jp_prec )%fnow(:,:,1), & ! <<= in 476 587 & sf(jp_snow )%fnow(:,:,1), tsk_m, & ! <<= in 477 & zsen, z evp )! <=> in out588 & zsen, zlat, zevp ) ! <=> in out 478 589 ENDIF 479 590 ! … … 486 597 qsr_ice(:,:,1) = sf(jp_qsr)%fnow(:,:,1) 487 598 ENDIF 488 tatm_ice(:,:) = sf(jp_tair)%fnow(:,:,1) 489 490 SELECT CASE( nhumi ) 491 CASE( np_humi_sph ) 492 qatm_ice(:,:) = sf(jp_humi)%fnow(:,:,1) 493 CASE( np_humi_dpt ) 494 qatm_ice(:,:) = q_sat( sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1) ) 495 CASE( np_humi_rlh ) 496 qatm_ice(:,:) = q_air_rh( 0.01_wp*sf(jp_humi)%fnow(:,:,1), sf(jp_tair)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1)) !LB: 0.01 => RH is % percent in file 497 END SELECT 599 tatm_ice(:,:) = sf(jp_tair)%fnow(:,:,1) !#LB: should it be POTENTIAL temperature instead ???? 600 !tatm_ice(:,:) = theta_air_zt(:,:) !#LB: THIS! ? 601 602 qatm_ice(:,:) = q_air_zt(:,:) !#LB: 498 603 499 604 tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac … … 507 612 508 613 509 SUBROUTINE blk_oce_1( kt, pwndi, pwndj, ptair, p humi, & ! inp614 SUBROUTINE blk_oce_1( kt, pwndi, pwndj, ptair, pqair, & ! inp 510 615 & pslp , pst , pu , pv, & ! inp 511 & puatm, pvatm, p qsr , pqlw ,& ! inp512 & ptsk , pssq , pcd_du, psen, p evp )! out616 & puatm, pvatm, pdqsr , pdqlw , & ! inp 617 & ptsk , pssq , pcd_du, psen, plat, pevp ) ! out 513 618 !!--------------------------------------------------------------------- 514 619 !! *** ROUTINE blk_oce_1 *** … … 523 628 !! ** Outputs : - pssq : surface humidity used to compute latent heat flux (kg/kg) 524 629 !! - pcd_du : Cd x |dU| at T-points (m/s) 525 !! - psen : Ch x |dU| at T-points (m/s) 526 !! - pevp : Ce x |dU| at T-points (m/s) 630 !! - psen : sensible heat flux (W/m^2) 631 !! - plat : latent heat flux (W/m^2) 632 !! - pevp : evaporation (mm/s) #lolo 527 633 !!--------------------------------------------------------------------- 528 634 INTEGER , INTENT(in ) :: kt ! time step index 529 635 REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndi ! atmospheric wind at U-point [m/s] 530 636 REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndj ! atmospheric wind at V-point [m/s] 531 REAL(wp), INTENT(in ), DIMENSION(:,:) :: p humi! specific humidity at T-points [kg/kg]637 REAL(wp), INTENT(in ), DIMENSION(:,:) :: pqair ! specific humidity at T-points [kg/kg] 532 638 REAL(wp), INTENT(in ), DIMENSION(:,:) :: ptair ! potential temperature at T-points [Kelvin] 533 639 REAL(wp), INTENT(in ), DIMENSION(:,:) :: pslp ! sea-level pressure [Pa] … … 537 643 REAL(wp), INTENT(in ), DIMENSION(:,:) :: puatm ! surface current seen by the atm at T-point (i-component) [m/s] 538 644 REAL(wp), INTENT(in ), DIMENSION(:,:) :: pvatm ! surface current seen by the atm at T-point (j-component) [m/s] 539 REAL(wp), INTENT(in ), DIMENSION(:,:) :: p qsr !540 REAL(wp), INTENT(in ), DIMENSION(:,:) :: p qlw !645 REAL(wp), INTENT(in ), DIMENSION(:,:) :: pdqsr ! downwelling solar (shortwave) radiation at surface [W/m^2] 646 REAL(wp), INTENT(in ), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] 541 647 REAL(wp), INTENT( out), DIMENSION(:,:) :: ptsk ! skin temp. (or SST if CS & WL not used) [Celsius] 542 648 REAL(wp), INTENT( out), DIMENSION(:,:) :: pssq ! specific humidity at pst [kg/kg] 543 REAL(wp), INTENT( out), DIMENSION(:,:) :: pcd_du ! Cd x |dU| at T-points [m/s] 544 REAL(wp), INTENT( out), DIMENSION(:,:) :: psen ! Ch x |dU| at T-points [m/s] 545 REAL(wp), INTENT( out), DIMENSION(:,:) :: pevp ! Ce x |dU| at T-points [m/s] 649 REAL(wp), INTENT( out), DIMENSION(:,:) :: pcd_du 650 REAL(wp), INTENT( out), DIMENSION(:,:) :: psen 651 REAL(wp), INTENT( out), DIMENSION(:,:) :: plat 652 REAL(wp), INTENT( out), DIMENSION(:,:) :: pevp 546 653 ! 547 654 INTEGER :: ji, jj ! dummy loop indices … … 553 660 REAL(wp), DIMENSION(jpi,jpj) :: ztau_i, ztau_j ! wind stress components at T-point 554 661 REAL(wp), DIMENSION(jpi,jpj) :: zU_zu ! bulk wind speed at height zu [m/s] 555 REAL(wp), DIMENSION(jpi,jpj) :: ztpot ! potential temperature of air at z=rn_zqt [K]556 REAL(wp), DIMENSION(jpi,jpj) :: zqair ! specific humidity of air at z=rn_zqt [kg/kg]557 662 REAL(wp), DIMENSION(jpi,jpj) :: zcd_oce ! momentum transfert coefficient over ocean 558 663 REAL(wp), DIMENSION(jpi,jpj) :: zch_oce ! sensible heat transfert coefficient over ocean 559 664 REAL(wp), DIMENSION(jpi,jpj) :: zce_oce ! latent heat transfert coefficient over ocean 560 REAL(wp), DIMENSION(jpi,jpj) :: zqla ! latent heat flux561 665 REAL(wp), DIMENSION(jpi,jpj) :: zztmp1, zztmp2 562 666 !!--------------------------------------------------------------------- … … 579 683 CALL wnd_cyc( kt, zwnd_i, zwnd_j ) ! add analytical tropical cyclone (Vincent et al. JGR 2012) 580 684 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 581 582 583 584 685 zwnd_i(ji,jj) = pwndi(ji,jj) + zwnd_i(ji,jj) 686 zwnd_j(ji,jj) = pwndj(ji,jj) + zwnd_j(ji,jj) 687 ! ... scalar wind at T-point (not masked) 688 wndm(ji,jj) = SQRT( zwnd_i(ji,jj) * zwnd_i(ji,jj) + zwnd_j(ji,jj) * zwnd_j(ji,jj) ) 585 689 END_2D 586 690 #else 587 691 ! ... scalar wind module at T-point (not masked) 588 692 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 589 693 wndm(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) ) 590 694 END_2D 591 695 #endif … … 597 701 zztmp = 1. - albo 598 702 IF( ln_dm2dc ) THEN 599 qsr(:,:) = zztmp * sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1)703 qsr(:,:) = zztmp * sbc_dcy( pdqsr(:,:) ) * tmask(:,:,1) 600 704 ELSE 601 qsr(:,:) = zztmp * sf(jp_qsr)%fnow(:,:,1) * tmask(:,:,1)705 qsr(:,:) = zztmp * pdqsr(:,:) * tmask(:,:,1) 602 706 ENDIF 603 707 … … 616 720 ENDIF 617 721 618 ! specific humidity of air at "rn_zqt" m above the sea619 SELECT CASE( nhumi )620 CASE( np_humi_sph )621 zqair(:,:) = phumi(:,:) ! what we read in file is already a spec. humidity!622 CASE( np_humi_dpt )623 !IF(lwp) WRITE(numout,*) ' *** blk_oce => computing q_air out of d_air and slp !' !LBrm624 zqair(:,:) = q_sat( phumi(:,:), pslp(:,:) )625 CASE( np_humi_rlh )626 !IF(lwp) WRITE(numout,*) ' *** blk_oce => computing q_air out of RH, t_air and slp !' !LBrm627 zqair(:,:) = q_air_rh( 0.01_wp*phumi(:,:), ptair(:,:), pslp(:,:) ) !LB: 0.01 => RH is % percent in file628 END SELECT629 !630 ! potential temperature of air at "rn_zqt" m above the sea631 IF( ln_abl ) THEN632 ztpot = ptair(:,:)633 ELSE634 ! Estimate of potential temperature at z=rn_zqt, based on adiabatic lapse-rate635 ! (see Josey, Gulev & Yu, 2013) / doi=10.1016/B978-0-12-391851-2.00005-2636 ! (since reanalysis products provide T at z, not theta !)637 !#LB: because AGRIF hates functions that return something else than a scalar, need to638 ! use scalar version of gamma_moist() ...639 IF( ln_tpot ) THEN640 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )641 ztpot(ji,jj) = ptair(ji,jj) + gamma_moist( ptair(ji,jj), zqair(ji,jj) ) * rn_zqt642 END_2D643 ELSE644 ztpot = ptair(:,:)645 ENDIF646 ENDIF647 648 722 !! Time to call the user-selected bulk parameterization for 649 723 !! == transfer coefficients ==! Cd, Ch, Ce at T-point, and more... … … 651 725 652 726 CASE( np_NCAR ) 653 CALL turb_ncar ( rn_zqt, rn_zu, ptsk, ztpot, pssq, zqair, wndm, & 654 & zcd_oce, zch_oce, zce_oce, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce ) 655 727 CALL turb_ncar ( rn_zqt, rn_zu, ptsk, ptair, pssq, pqair, wndm, & 728 & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu , & 729 & nb_iter=nn_iter_algo ) 730 ! 656 731 CASE( np_COARE_3p0 ) 657 CALL turb_coare3p0 ( kt, rn_zqt, rn_zu, ptsk, ztpot, pssq, zqair, wndm, ln_skin_cs, ln_skin_wl, & 658 & zcd_oce, zch_oce, zce_oce, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce, & 659 & Qsw=qsr(:,:), rad_lw=pqlw(:,:), slp=pslp(:,:) ) 660 732 CALL turb_coare3p0( kt, rn_zqt, rn_zu, ptsk, ptair, pssq, pqair, wndm, & 733 & ln_skin_cs, ln_skin_wl, & 734 & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, & 735 & nb_iter=nn_iter_algo, & 736 & Qsw=qsr(:,:), rad_lw=pdqlw(:,:), slp=pslp(:,:) ) 737 ! 661 738 CASE( np_COARE_3p6 ) 662 CALL turb_coare3p6 ( kt, rn_zqt, rn_zu, ptsk, ztpot, pssq, zqair, wndm, ln_skin_cs, ln_skin_wl, & 663 & zcd_oce, zch_oce, zce_oce, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce, & 664 & Qsw=qsr(:,:), rad_lw=pqlw(:,:), slp=pslp(:,:) ) 665 739 CALL turb_coare3p6( kt, rn_zqt, rn_zu, ptsk, ptair, pssq, pqair, wndm, & 740 & ln_skin_cs, ln_skin_wl, & 741 & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, & 742 & nb_iter=nn_iter_algo, & 743 & Qsw=qsr(:,:), rad_lw=pdqlw(:,:), slp=pslp(:,:) ) 744 ! 666 745 CASE( np_ECMWF ) 667 CALL turb_ecmwf ( kt, rn_zqt, rn_zu, ptsk, ztpot, pssq, zqair, wndm, ln_skin_cs, ln_skin_wl, & 668 & zcd_oce, zch_oce, zce_oce, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce, & 669 & Qsw=qsr(:,:), rad_lw=pqlw(:,:), slp=pslp(:,:) ) 670 746 CALL turb_ecmwf ( kt, rn_zqt, rn_zu, ptsk, ptair, pssq, pqair, wndm, & 747 & ln_skin_cs, ln_skin_wl, & 748 & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, & 749 & nb_iter=nn_iter_algo, & 750 & Qsw=qsr(:,:), rad_lw=pdqlw(:,:), slp=pslp(:,:) ) 751 ! 752 CASE( np_ANDREAS ) 753 CALL turb_andreas ( rn_zqt, rn_zu, ptsk, ptair, pssq, pqair, wndm, & 754 & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu , & 755 & nb_iter=nn_iter_algo ) 756 ! 671 757 CASE DEFAULT 672 CALL ctl_stop( 'STOP', 'sbc_oce: non-existing bulk formulaselected' )673 758 CALL ctl_stop( 'STOP', 'sbc_oce: non-existing bulk parameterizaton selected' ) 759 ! 674 760 END SELECT 675 761 676 762 IF( iom_use('Cd_oce') ) CALL iom_put("Cd_oce", zcd_oce * tmask(:,:,1)) 677 763 IF( iom_use('Ce_oce') ) CALL iom_put("Ce_oce", zce_oce * tmask(:,:,1)) 678 764 IF( iom_use('Ch_oce') ) CALL iom_put("Ch_oce", zch_oce * tmask(:,:,1)) 679 765 !! LB: mainly here for debugging purpose: 680 IF( iom_use('theta_zt') ) CALL iom_put("theta_zt", ( ztpot-rt0) * tmask(:,:,1)) ! potential temperature at z=zt681 IF( iom_use('q_zt') ) CALL iom_put("q_zt", zqair * tmask(:,:,1)) ! specific humidity "682 IF( iom_use('theta_zu') ) CALL iom_put("theta_zu", (t _zu -rt0) * tmask(:,:,1)) ! potential temperature at z=zu766 IF( iom_use('theta_zt') ) CALL iom_put("theta_zt", (ptair-rt0) * tmask(:,:,1)) ! potential temperature at z=zt 767 IF( iom_use('q_zt') ) CALL iom_put("q_zt", pqair * tmask(:,:,1)) ! specific humidity " 768 IF( iom_use('theta_zu') ) CALL iom_put("theta_zu", (theta_zu -rt0) * tmask(:,:,1)) ! potential temperature at z=zu 683 769 IF( iom_use('q_zu') ) CALL iom_put("q_zu", q_zu * tmask(:,:,1)) ! specific humidity " 684 770 IF( iom_use('ssq') ) CALL iom_put("ssq", pssq * tmask(:,:,1)) ! saturation specific humidity at z=0 685 771 IF( iom_use('wspd_blk') ) CALL iom_put("wspd_blk", zU_zu * tmask(:,:,1)) ! bulk wind speed at z=zu 686 772 687 773 IF( ln_skin_cs .OR. ln_skin_wl ) THEN 688 774 !! ptsk and pssq have been updated!!! … … 696 782 END IF 697 783 698 ! Turbulent fluxes over ocean => BULK_FORMULA @ sbc blk_phy.F90784 ! Turbulent fluxes over ocean => BULK_FORMULA @ sbc_phy.F90 699 785 ! ------------------------------------------------------------- 700 786 701 787 IF( ln_abl ) THEN !== ABL formulation ==! multiplication by rho_air and turbulent fluxes computation done in ablstp 702 788 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 703 704 705 706 707 708 rhoa(ji,jj) = rho_air( ptair(ji,jj), phumi(ji,jj), pslp(ji,jj) )789 zztmp = zU_zu(ji,jj) 790 wndm(ji,jj) = zztmp ! Store zU_zu in wndm to compute ustar2 in ablmod 791 pcd_du(ji,jj) = zztmp * zcd_oce(ji,jj) 792 psen(ji,jj) = zztmp * zch_oce(ji,jj) 793 pevp(ji,jj) = zztmp * zce_oce(ji,jj) 794 rhoa(ji,jj) = rho_air( ptair(ji,jj), pqair(ji,jj), pslp(ji,jj) ) 709 795 END_2D 710 796 ELSE !== BLK formulation ==! turbulent fluxes computation 711 CALL BULK_FORMULA( rn_zu, ptsk(:,:), pssq(:,:), t _zu(:,:), q_zu(:,:), &797 CALL BULK_FORMULA( rn_zu, ptsk(:,:), pssq(:,:), theta_zu(:,:), q_zu(:,:), & 712 798 & zcd_oce(:,:), zch_oce(:,:), zce_oce(:,:), & 713 799 & wndm(:,:), zU_zu(:,:), pslp(:,:), & 714 & taum(:,:), psen(:,:), zqla(:,:), &800 & taum(:,:), psen(:,:), plat(:,:), & 715 801 & pEvap=pevp(:,:), prhoa=rhoa(:,:), pfact_evap=rn_efac ) 716 802 717 zqla(:,:) = zqla(:,:) * tmask(:,:,1)718 803 psen(:,:) = psen(:,:) * tmask(:,:,1) 804 plat(:,:) = plat(:,:) * tmask(:,:,1) 719 805 taum(:,:) = taum(:,:) * tmask(:,:,1) 720 806 pevp(:,:) = pevp(:,:) * tmask(:,:,1) 721 807 722 808 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 723 724 809 IF( wndm(ji,jj) > 0._wp ) THEN 810 zztmp = taum(ji,jj) / wndm(ji,jj) 725 811 #if defined key_cyclone 726 727 812 ztau_i(ji,jj) = zztmp * zwnd_i(ji,jj) 813 ztau_j(ji,jj) = zztmp * zwnd_j(ji,jj) 728 814 #else 729 730 731 #endif 732 733 734 ztau_j(ji,jj) = 0._wp735 815 ztau_i(ji,jj) = zztmp * pwndi(ji,jj) 816 ztau_j(ji,jj) = zztmp * pwndj(ji,jj) 817 #endif 818 ELSE 819 ztau_i(ji,jj) = 0._wp 820 ztau_j(ji,jj) = 0._wp 821 ENDIF 736 822 END_2D 737 823 … … 739 825 zstmax = MIN( rn_stau_a * 3._wp + rn_stau_b, 0._wp ) ! set the max value of Stau corresponding to a wind of 3 m/s (<0) 740 826 DO_2D( 0, 1, 0, 1 ) ! end at jpj and jpi, as ztau_j(ji,jj+1) ztau_i(ji+1,jj) used in the next loop 741 742 743 744 827 zstau = MIN( rn_stau_a * wndm(ji,jj) + rn_stau_b, zstmax ) ! stau (<0) must be smaller than zstmax 828 ztau_i(ji,jj) = ztau_i(ji,jj) + zstau * ( 0.5_wp * ( pu(ji-1,jj ) + pu(ji,jj) ) - puatm(ji,jj) ) 829 ztau_j(ji,jj) = ztau_j(ji,jj) + zstau * ( 0.5_wp * ( pv(ji ,jj-1) + pv(ji,jj) ) - pvatm(ji,jj) ) 830 taum(ji,jj) = SQRT( ztau_i(ji,jj) * ztau_i(ji,jj) + ztau_j(ji,jj) * ztau_j(ji,jj) ) 745 831 END_2D 746 832 ENDIF … … 750 836 ! Note that coastal wind stress is not used in the code... so this extra care has no effect 751 837 DO_2D( 0, 0, 0, 0 ) ! start loop at 2, in case ln_crt_fbk = T 752 753 754 755 838 utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( ztau_i(ji,jj) + ztau_i(ji+1,jj ) ) & 839 & * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1)) 840 vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( ztau_j(ji,jj) + ztau_j(ji ,jj+1) ) & 841 & * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1)) 756 842 END_2D 843 757 844 758 845 IF( ln_crt_fbk ) THEN … … 762 849 ENDIF 763 850 764 CALL iom_put( "taum_oce", taum ) ! output wind stress module851 CALL iom_put( "taum_oce", taum*tmask(:,:,1) ) ! output wind stress module 765 852 766 853 IF(sn_cfctl%l_prtctl) THEN 767 CALL prt_ctl( tab2d_1=wndm , clinfo1=' blk_oce_1: wndm : ') 768 CALL prt_ctl( tab2d_1=utau , clinfo1=' blk_oce_1: utau : ', mask1=umask, & 769 & tab2d_2=vtau , clinfo2=' vtau : ', mask2=vmask ) 854 CALL prt_ctl( tab2d_1=pssq , clinfo1=' blk_oce_1: pssq : ') 855 CALL prt_ctl( tab2d_1=wndm , clinfo1=' blk_oce_1: wndm : ') 856 CALL prt_ctl( tab2d_1=utau , clinfo1=' blk_oce_1: utau : ', mask1=umask, & 857 & tab2d_2=vtau , clinfo2=' vtau : ', mask2=vmask ) 858 CALL prt_ctl( tab2d_1=zcd_oce, clinfo1=' blk_oce_1: Cd : ') 770 859 ENDIF 771 860 ! 772 861 ENDIF !IF( ln_abl ) 773 862 774 863 ptsk(:,:) = ( ptsk(:,:) - rt0 ) * tmask(:,:,1) ! Back to Celsius 775 864 776 865 IF( ln_skin_cs .OR. ln_skin_wl ) THEN 777 866 CALL iom_put( "t_skin" , ptsk ) ! T_skin in Celsius 778 867 CALL iom_put( "dt_skin" , ptsk - pst ) ! T_skin - SST temperature difference... 779 868 ENDIF 780 781 IF(sn_cfctl%l_prtctl) THEN782 CALL prt_ctl( tab2d_1=pevp , clinfo1=' blk_oce_1: pevp : ' )783 CALL prt_ctl( tab2d_1=psen , clinfo1=' blk_oce_1: psen : ' )784 CALL prt_ctl( tab2d_1=pssq , clinfo1=' blk_oce_1: pssq : ' )785 ENDIF786 869 ! 787 870 END SUBROUTINE blk_oce_1 788 871 789 790 SUBROUTINE blk_oce_2( ptair, p qsr, pqlw, pprec,& ! <<= in791 & psnow, ptsk, psen, pevp ) ! <<= in872 873 SUBROUTINE blk_oce_2( ptair, pdqlw, pprec, psnow, & ! <<= in 874 & ptsk, psen, plat, pevp ) ! <<= in 792 875 !!--------------------------------------------------------------------- 793 876 !! *** ROUTINE blk_oce_2 *** … … 805 888 !! - emp : evaporation minus precipitation (kg/m2/s) 806 889 !!--------------------------------------------------------------------- 807 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptair 808 REAL(wp), INTENT(in), DIMENSION(:,:) :: pqsr 809 REAL(wp), INTENT(in), DIMENSION(:,:) :: pqlw 890 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptair ! potential temperature of air #LB: confirm! 891 REAL(wp), INTENT(in), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] 810 892 REAL(wp), INTENT(in), DIMENSION(:,:) :: pprec 811 893 REAL(wp), INTENT(in), DIMENSION(:,:) :: psnow 812 894 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptsk ! SKIN surface temperature [Celsius] 813 895 REAL(wp), INTENT(in), DIMENSION(:,:) :: psen 896 REAL(wp), INTENT(in), DIMENSION(:,:) :: plat 814 897 REAL(wp), INTENT(in), DIMENSION(:,:) :: pevp 815 898 ! 816 899 INTEGER :: ji, jj ! dummy loop indices 817 900 REAL(wp) :: zztmp,zz1,zz2,zz3 ! local variable 818 REAL(wp), DIMENSION(jpi,jpj) :: ztskk ! skin temp. in Kelvin 819 REAL(wp), DIMENSION(jpi,jpj) :: zqlw ! long wave and sensible heat fluxes 820 REAL(wp), DIMENSION(jpi,jpj) :: zqla ! latent heat fluxes and evaporation 901 REAL(wp), DIMENSION(jpi,jpj) :: zqlw ! net long wave radiative heat flux 821 902 !!--------------------------------------------------------------------- 822 903 ! 823 904 ! local scalars ( place there for vector optimisation purposes) 824 905 825 826 ztskk(:,:) = ptsk(:,:) + rt0 ! => ptsk in Kelvin rather than Celsius827 828 906 ! ----------------------------------------------------------------------------- ! 829 907 ! III Net longwave radiative FLUX ! 830 908 ! ----------------------------------------------------------------------------- ! 831 832 !! LB: now moved after Turbulent fluxes because must use the skin temperature rather that the SST 833 !! (ztskk is skin temperature if ln_skin_cs==.TRUE. .OR. ln_skin_wl==.TRUE.) 834 zqlw(:,:) = emiss_w * ( pqlw(:,:) - stefan*ztskk(:,:)*ztskk(:,:)*ztskk(:,:)*ztskk(:,:) ) * tmask(:,:,1) ! Net radiative longwave flux 835 836 ! Latent flux over ocean 837 ! ----------------------- 838 839 ! use scalar version of L_vap() for AGRIF compatibility 840 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 841 zqla(ji,jj) = - L_vap( ztskk(ji,jj) ) * pevp(ji,jj) ! Latent Heat flux !!GS: possibility to add a global qla to avoid recomputation after abl update 842 END_2D 843 844 IF(sn_cfctl%l_prtctl) THEN 845 CALL prt_ctl( tab2d_1=zqla , clinfo1=' blk_oce_2: zqla : ' ) 846 CALL prt_ctl( tab2d_1=zqlw , clinfo1=' blk_oce_2: zqlw : ', tab2d_2=qsr, clinfo2=' qsr : ' ) 847 848 ENDIF 909 !! #LB: now moved after Turbulent fluxes because must use the skin temperature rather than bulk SST 910 !! (ptsk is skin temperature if ln_skin_cs==.TRUE. .OR. ln_skin_wl==.TRUE.) 911 zqlw(:,:) = qlw_net( pdqlw(:,:), ptsk(:,:)+rt0 ) 849 912 850 913 ! ----------------------------------------------------------------------------- ! … … 855 918 & - pprec(:,:) * rn_pfac ) * tmask(:,:,1) 856 919 ! 857 qns(:,:) = zqlw(:,:) + psen(:,:) + zqla(:,:) & ! Downward Non Solar920 qns(:,:) = zqlw(:,:) + psen(:,:) + plat(:,:) & ! Downward Non Solar 858 921 & - psnow(:,:) * rn_pfac * rLfus & ! remove latent melting heat for solid precip 859 922 & - pevp(:,:) * ptsk(:,:) * rcp & ! remove evap heat content at SST … … 865 928 ! 866 929 #if defined key_si3 867 qns_oce(:,:) = zqlw(:,:) + psen(:,:) + zqla(:,:) ! non solar without emp (only needed by SI3)930 qns_oce(:,:) = zqlw(:,:) + psen(:,:) + plat(:,:) ! non solar without emp (only needed by SI3) 868 931 qsr_oce(:,:) = qsr(:,:) 869 932 #endif … … 873 936 CALL iom_put( "qlw_oce" , zqlw ) ! output downward longwave heat over the ocean 874 937 CALL iom_put( "qsb_oce" , psen ) ! output downward sensible heat over the ocean 875 CALL iom_put( "qla_oce" , zqla) ! output downward latent heat over the ocean938 CALL iom_put( "qla_oce" , plat ) ! output downward latent heat over the ocean 876 939 tprecip(:,:) = pprec(:,:) * rn_pfac * tmask(:,:,1) ! output total precipitation [kg/m2/s] 877 940 sprecip(:,:) = psnow(:,:) * rn_pfac * tmask(:,:,1) ! output solid precipitation [kg/m2/s] … … 880 943 ! 881 944 IF ( nn_ice == 0 ) THEN 882 CALL iom_put( "qemp_oce" , qns-zqlw-psen- zqla) ! output downward heat content of E-P over the ocean945 CALL iom_put( "qemp_oce" , qns-zqlw-psen-plat ) ! output downward heat content of E-P over the ocean 883 946 CALL iom_put( "qns_oce" , qns ) ! output downward non solar heat over the ocean 884 947 CALL iom_put( "qsr_oce" , qsr ) ! output downward solar heat over the ocean … … 888 951 IF(sn_cfctl%l_prtctl) THEN 889 952 CALL prt_ctl(tab2d_1=zqlw , clinfo1=' blk_oce_2: zqlw : ') 890 CALL prt_ctl(tab2d_1=zqla , clinfo1=' blk_oce_2: zqla : ', tab2d_2=qsr , clinfo2=' qsr : ') 953 CALL prt_ctl(tab2d_1=psen , clinfo1=' blk_oce_2: psen : ' ) 954 CALL prt_ctl(tab2d_1=plat , clinfo1=' blk_oce_2: plat : ' ) 955 CALL prt_ctl(tab2d_1=qns , clinfo1=' blk_oce_2: qns : ' ) 891 956 CALL prt_ctl(tab2d_1=emp , clinfo1=' blk_oce_2: emp : ') 892 957 ENDIF … … 902 967 !! blk_ice_2 : provide the heat and mass fluxes at air-ice interface 903 968 !! blk_ice_qcn : provide ice surface temperature and snow/ice conduction flux (emulating conduction flux) 904 !! Cdn10_Lupkes2012 : Lupkes et al. (2012) air-ice drag905 !! Cdn10_Lupkes2015 : Lupkes et al. (2015) air-ice drag906 969 !!---------------------------------------------------------------------- 907 970 908 SUBROUTINE blk_ice_1( pwndi, pwndj, ptair, p humi, pslp , puice, pvice, ptsui, & ! inputs971 SUBROUTINE blk_ice_1( pwndi, pwndj, ptair, pqair, pslp , puice, pvice, ptsui, & ! inputs 909 972 & putaui, pvtaui, pseni, pevpi, pssqi, pcd_dui ) ! optional outputs 910 973 !!--------------------------------------------------------------------- … … 921 984 REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pwndj ! atmospheric wind at T-point [m/s] 922 985 REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: ptair ! atmospheric wind at T-point [m/s] 923 REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: p humi! atmospheric wind at T-point [m/s]986 REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pqair ! atmospheric wind at T-point [m/s] 924 987 REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: puice ! sea-ice velocity on I or C grid [m/s] 925 988 REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pvice ! " … … 934 997 INTEGER :: ji, jj ! dummy loop indices 935 998 REAL(wp) :: zootm_su ! sea-ice surface mean temperature 936 REAL(wp) :: zztmp1, zztmp2 ! temporary arrays 937 REAL(wp), DIMENSION(jpi,jpj) :: zcd_dui ! transfer coefficient for momentum (tau) 938 !!--------------------------------------------------------------------- 939 ! 940 999 REAL(wp) :: zztmp1, zztmp2 ! temporary scalars 1000 REAL(wp), DIMENSION(jpi,jpj) :: ztmp ! temporary array 1001 !!--------------------------------------------------------------------- 1002 ! 1003 ! LB: ptsui is in K !!! 1004 ! 941 1005 ! ------------------------------------------------------------ ! 942 1006 ! Wind module relative to the moving ice ( U10m - U_ice ) ! … … 944 1008 ! C-grid ice dynamics : U & V-points (same as ocean) 945 1009 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 946 1010 wndm_ice(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) ) 947 1011 END_2D 948 1012 ! 949 1013 ! Make ice-atm. drag dependent on ice concentration 950 IF ( ln_Cd_L12 ) THEN ! calculate new drag from Lupkes(2012) equations 951 CALL Cdn10_Lupkes2012( Cd_ice ) 952 Ch_ice(:,:) = Cd_ice(:,:) ! momentum and heat transfer coef. are considered identical 953 Ce_ice(:,:) = Cd_ice(:,:) 954 ELSEIF( ln_Cd_L15 ) THEN ! calculate new drag from Lupkes(2015) equations 955 CALL Cdn10_Lupkes2015( ptsui, pslp, Cd_ice, Ch_ice ) 956 Ce_ice(:,:) = Ch_ice(:,:) ! sensible and latent heat transfer coef. are considered identical 957 ENDIF 958 959 IF( iom_use('Cd_ice') ) CALL iom_put("Cd_ice", Cd_ice) 960 IF( iom_use('Ce_ice') ) CALL iom_put("Ce_ice", Ce_ice) 961 IF( iom_use('Ch_ice') ) CALL iom_put("Ch_ice", Ch_ice) 962 963 ! local scalars ( place there for vector optimisation purposes) 964 zcd_dui(:,:) = wndm_ice(:,:) * Cd_ice(:,:) 1014 1015 1016 SELECT CASE( nblk_ice ) 1017 1018 CASE( np_ice_cst ) 1019 ! Constant bulk transfer coefficients over sea-ice: 1020 Cd_ice(:,:) = rn_Cd_i 1021 Ch_ice(:,:) = rn_Ch_i 1022 Ce_ice(:,:) = rn_Ce_i 1023 ! no height adjustment, keeping zt values: 1024 theta_zu_i(:,:) = ptair(:,:) 1025 q_zu_i(:,:) = pqair(:,:) 1026 1027 CASE( np_ice_lu12 ) 1028 ztmp(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ! temporary array for SSQ 1029 CALL turb_ice_lu12( rn_zqt, rn_zu, ptsui, ptair, ztmp, pqair, wndm_ice, fr_i, & 1030 & Cd_ice, Ch_ice, Ce_ice, theta_zu_i, q_zu_i ) 1031 !! 1032 CASE( np_ice_lg15 ) ! calculate new drag from Lupkes(2015) equations 1033 ztmp(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ! temporary array for SSQ 1034 CALL turb_ice_lg15( rn_zqt, rn_zu, ptsui, ptair, ztmp, pqair, wndm_ice, fr_i, & 1035 & Cd_ice, Ch_ice, Ce_ice, theta_zu_i, q_zu_i ) 1036 !! 1037 END SELECT 1038 1039 IF( iom_use('Cd_ice').OR.iom_use('Ce_ice').OR.iom_use('Ch_ice').OR.iom_use('taum_ai') ) & 1040 & ztmp(:,:) = ( 1._wp - MAX(0._wp, SIGN( 1._wp, 1.E-6_wp - fr_i )) )*tmask(:,:,1) ! mask for presence of ice ! 1041 1042 IF( iom_use('Cd_ice') ) CALL iom_put("Cd_ice", Cd_ice*ztmp) 1043 IF( iom_use('Ce_ice') ) CALL iom_put("Ce_ice", Ce_ice*ztmp) 1044 IF( iom_use('Ch_ice') ) CALL iom_put("Ch_ice", Ch_ice*ztmp) 1045 965 1046 966 1047 IF( ln_blk ) THEN … … 969 1050 ! ---------------------------------------------------- ! 970 1051 ! supress moving ice in wind stress computation as we don't know how to do it properly... 971 DO_2D( 0, 1, 0, 1 ) ! at T point 972 putaui(ji,jj) = rhoa(ji,jj) * zcd_dui(ji,jj) * pwndi(ji,jj) 973 pvtaui(ji,jj) = rhoa(ji,jj) * zcd_dui(ji,jj) * pwndj(ji,jj) 1052 DO_2D( 0, 1, 0, 1 ) ! at T point 1053 zztmp1 = rhoa(ji,jj) * Cd_ice(ji,jj) * wndm_ice(ji,jj) 1054 putaui(ji,jj) = zztmp1 * pwndi(ji,jj) 1055 pvtaui(ji,jj) = zztmp1 * pwndj(ji,jj) 974 1056 END_2D 1057 !#LB: saving the module of the ai wind-stress: NOT weighted by the ice concentration !!! 1058 IF(iom_use('taum_ai')) CALL iom_put( 'taum_ai', SQRT( putaui*putaui + pvtaui*pvtaui )*ztmp ) 975 1059 ! 976 1060 DO_2D( 0, 0, 0, 0 ) ! U & V-points (same as ocean). 977 ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology 978 zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) 979 zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) ) 980 putaui(ji,jj) = zztmp1 * ( putaui(ji,jj) + putaui(ji+1,jj ) ) 981 pvtaui(ji,jj) = zztmp2 * ( pvtaui(ji,jj) + pvtaui(ji ,jj+1) ) 1061 !#LB: QUESTION?? so SI3 expects wind stress vector to be provided at U & V points? Not at T-points ? 1062 ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology 1063 zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) 1064 zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) ) 1065 putaui(ji,jj) = zztmp1 * ( putaui(ji,jj) + putaui(ji+1,jj ) ) 1066 pvtaui(ji,jj) = zztmp2 * ( pvtaui(ji,jj) + pvtaui(ji ,jj+1) ) 982 1067 END_2D 983 1068 CALL lbc_lnk_multi( 'sbcblk', putaui, 'U', -1._wp, pvtaui, 'V', -1._wp ) … … 986 1071 & , tab2d_2=pvtaui , clinfo2=' pvtaui : ' ) 987 1072 ELSE ! ln_abl 988 zztmp1 = 11637800.0_wp989 zztmp2 = -5897.8_wp990 1073 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 991 pcd_dui(ji,jj) = zcd_dui (ji,jj) 992 pseni (ji,jj) = wndm_ice(ji,jj) * Ch_ice(ji,jj) 993 pevpi (ji,jj) = wndm_ice(ji,jj) * Ce_ice(ji,jj) 994 zootm_su = zztmp2 / ptsui(ji,jj) ! ptsui is in K (it can't be zero ??) 995 pssqi (ji,jj) = zztmp1 * EXP( zootm_su ) / rhoa(ji,jj) 1074 pcd_dui(ji,jj) = wndm_ice(ji,jj) * Cd_ice(ji,jj) 1075 pseni (ji,jj) = wndm_ice(ji,jj) * Ch_ice(ji,jj) 1076 pevpi (ji,jj) = wndm_ice(ji,jj) * Ce_ice(ji,jj) 996 1077 END_2D 997 ENDIF 1078 !#LB: 1079 pssqi(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ; ! more accurate way to obtain ssq ! 1080 !#LB. 1081 ENDIF !IF( ln_blk ) 998 1082 ! 999 1083 IF(sn_cfctl%l_prtctl) CALL prt_ctl(tab2d_1=wndm_ice , clinfo1=' blk_ice: wndm_ice : ') … … 1002 1086 1003 1087 1004 SUBROUTINE blk_ice_2( ptsu, phs, phi, palb, ptair, p humi, pslp, pqlw, pprec, psnow )1088 SUBROUTINE blk_ice_2( ptsu, phs, phi, palb, ptair, pqair, pslp, pdqlw, pprec, psnow ) 1005 1089 !!--------------------------------------------------------------------- 1006 1090 !! *** ROUTINE blk_ice_2 *** … … 1018 1102 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness 1019 1103 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: palb ! ice albedo (all skies) 1020 REAL(wp), DIMENSION(:,: ), INTENT(in) :: ptair 1021 REAL(wp), DIMENSION(:,: ), INTENT(in) :: p humi1104 REAL(wp), DIMENSION(:,: ), INTENT(in) :: ptair ! potential temperature of air #LB: okay ??? 1105 REAL(wp), DIMENSION(:,: ), INTENT(in) :: pqair ! specific humidity of air 1022 1106 REAL(wp), DIMENSION(:,: ), INTENT(in) :: pslp 1023 REAL(wp), DIMENSION(:,: ), INTENT(in) :: p qlw1107 REAL(wp), DIMENSION(:,: ), INTENT(in) :: pdqlw 1024 1108 REAL(wp), DIMENSION(:,: ), INTENT(in) :: pprec 1025 1109 REAL(wp), DIMENSION(:,: ), INTENT(in) :: psnow 1026 1110 !! 1027 1111 INTEGER :: ji, jj, jl ! dummy loop indices 1028 REAL(wp) :: zst 3! local variable1112 REAL(wp) :: zst, zst3, zsq ! local variable 1029 1113 REAL(wp) :: zcoef_dqlw, zcoef_dqla ! - - 1030 REAL(wp) :: zztmp, zztmp2, z1_rLsub ! - - 1031 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_st ! inverse of surface temperature 1114 REAL(wp) :: zztmp, zzblk, zztmp1, z1_rLsub ! - - 1032 1115 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qlw ! long wave heat flux over ice 1033 1116 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qsb ! sensible heat flux over ice … … 1035 1118 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_dqsb ! sensible heat sensitivity over ice 1036 1119 REAL(wp), DIMENSION(jpi,jpj) :: zevap, zsnw ! evaporation and snw distribution after wind blowing (SI3) 1037 REAL(wp), DIMENSION(jpi,jpj) :: zqair ! specific humidity of air at z=rn_zqt [kg/kg] !LB1038 1120 REAL(wp), DIMENSION(jpi,jpj) :: ztmp, ztmp2 1039 1121 REAL(wp), DIMENSION(jpi,jpj) :: ztri 1040 1122 !!--------------------------------------------------------------------- 1041 1123 ! 1042 zcoef_dqlw = 4._wp * 0.95_wp * stefan ! local scalars 1043 zcoef_dqla = -rLsub * 11637800._wp * (-5897.8_wp) !LB: BAD! 1044 ! 1045 SELECT CASE( nhumi ) 1046 CASE( np_humi_sph ) 1047 zqair(:,:) = phumi(:,:) ! what we read in file is already a spec. humidity! 1048 CASE( np_humi_dpt ) 1049 zqair(:,:) = q_sat( phumi(:,:), pslp ) 1050 CASE( np_humi_rlh ) 1051 zqair(:,:) = q_air_rh( 0.01_wp*phumi(:,:), ptair(:,:), pslp(:,:) ) !LB: 0.01 => RH is % percent in file 1052 END SELECT 1053 ! 1124 zcoef_dqlw = 4._wp * emiss_i * stefan ! local scalars 1125 ! 1126 1054 1127 zztmp = 1. / ( 1. - albo ) 1055 WHERE( ptsu(:,:,:) /= 0._wp ) 1056 z1_st(:,:,:) = 1._wp / ptsu(:,:,:) 1057 ELSEWHERE 1058 z1_st(:,:,:) = 0._wp 1059 END WHERE 1128 dqla_ice(:,:,:) = 0._wp 1129 1060 1130 ! ! ========================== ! 1061 1131 DO jl = 1, jpl ! Loop over ice categories ! 1062 1132 ! ! ========================== ! 1063 DO jj = 1 , jpj 1064 DO ji = 1, jpi 1065 ! ----------------------------! 1066 ! I Radiative FLUXES ! 1067 ! ----------------------------! 1068 zst3 = ptsu(ji,jj,jl) * ptsu(ji,jj,jl) * ptsu(ji,jj,jl) 1069 ! Short Wave (sw) 1070 qsr_ice(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj) 1071 ! Long Wave (lw) 1072 z_qlw(ji,jj,jl) = 0.95 * ( pqlw(ji,jj) - stefan * ptsu(ji,jj,jl) * zst3 ) * tmask(ji,jj,1) 1073 ! lw sensitivity 1074 z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3 1075 1076 ! ----------------------------! 1077 ! II Turbulent FLUXES ! 1078 ! ----------------------------! 1079 1080 ! ... turbulent heat fluxes with Ch_ice recalculated in blk_ice_1 1081 ! Sensible Heat 1082 z_qsb(ji,jj,jl) = rhoa(ji,jj) * rCp_air * Ch_ice(ji,jj) * wndm_ice(ji,jj) * (ptsu(ji,jj,jl) - ptair(ji,jj)) 1083 ! Latent Heat 1084 zztmp2 = EXP( -5897.8 * z1_st(ji,jj,jl) ) 1085 qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, rhoa(ji,jj) * rLsub * Ce_ice(ji,jj) * wndm_ice(ji,jj) * & 1086 & ( 11637800. * zztmp2 / rhoa(ji,jj) - zqair(ji,jj) ) ) 1087 ! Latent heat sensitivity for ice (Dqla/Dt) 1088 IF( qla_ice(ji,jj,jl) > 0._wp ) THEN 1089 dqla_ice(ji,jj,jl) = rn_efac * zcoef_dqla * Ce_ice(ji,jj) * wndm_ice(ji,jj) * & 1090 & z1_st(ji,jj,jl) * z1_st(ji,jj,jl) * zztmp2 1091 ELSE 1092 dqla_ice(ji,jj,jl) = 0._wp 1093 ENDIF 1094 1095 ! Sensible heat sensitivity (Dqsb_ice/Dtn_ice) 1096 z_dqsb(ji,jj,jl) = rhoa(ji,jj) * rCp_air * Ch_ice(ji,jj) * wndm_ice(ji,jj) 1097 1098 ! ----------------------------! 1099 ! III Total FLUXES ! 1100 ! ----------------------------! 1101 ! Downward Non Solar flux 1102 qns_ice (ji,jj,jl) = z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - qla_ice (ji,jj,jl) 1103 ! Total non solar heat flux sensitivity for ice 1104 dqns_ice(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + dqla_ice(ji,jj,jl) ) 1105 END DO 1106 ! 1107 END DO 1133 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 1134 1135 zst = ptsu(ji,jj,jl) ! surface temperature of sea-ice [K] 1136 zsq = q_sat( zst, pslp(ji,jj), l_ice=.TRUE. ) ! surface saturation specific humidity when ice present 1137 1138 ! ----------------------------! 1139 ! I Radiative FLUXES ! 1140 ! ----------------------------! 1141 ! Short Wave (sw) 1142 qsr_ice(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj) 1143 1144 ! Long Wave (lw) 1145 zst3 = zst * zst * zst 1146 z_qlw(ji,jj,jl) = emiss_i * ( pdqlw(ji,jj) - stefan * zst * zst3 ) * tmask(ji,jj,1) 1147 ! lw sensitivity 1148 z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3 1149 1150 ! ----------------------------! 1151 ! II Turbulent FLUXES ! 1152 ! ----------------------------! 1153 1154 ! ... turbulent heat fluxes with Ch_ice recalculated in blk_ice_1 1155 1156 ! Common term in bulk F. equations... 1157 zzblk = rhoa(ji,jj) * wndm_ice(ji,jj) 1158 1159 ! Sensible Heat 1160 zztmp1 = zzblk * rCp_air * Ch_ice(ji,jj) 1161 z_qsb (ji,jj,jl) = zztmp1 * (zst - theta_zu_i(ji,jj)) 1162 z_dqsb(ji,jj,jl) = zztmp1 ! ==> Qsens sensitivity (Dqsb_ice/Dtn_ice) 1163 1164 ! Latent Heat 1165 zztmp1 = zzblk * rLsub * Ce_ice(ji,jj) 1166 qla_ice(ji,jj,jl) = MAX( zztmp1 * (zsq - q_zu_i(ji,jj)) , 0._wp ) ! #LB: only sublimation (and not condensation) ??? 1167 IF(qla_ice(ji,jj,jl)>0._wp) dqla_ice(ji,jj,jl) = zztmp1*dq_sat_dt_ice(zst, pslp(ji,jj)) ! ==> Qlat sensitivity (dQlat/dT) 1168 ! !#LB: dq_sat_dt_ice() in "sbc_phy.F90" 1169 !#LB: without this unjustified "condensation sensure": 1170 !qla_ice( ji,jj,jl) = zztmp1 * (zsq - q_zu_i(ji,jj)) 1171 !dqla_ice(ji,jj,jl) = zztmp1 * dq_sat_dt_ice(zst, pslp(ji,jj)) ! ==> Qlat sensitivity (dQlat/dT) 1172 1173 1174 1175 ! ----------------------------! 1176 ! III Total FLUXES ! 1177 ! ----------------------------! 1178 1179 ! Downward Non Solar flux 1180 qns_ice (ji,jj,jl) = z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - qla_ice (ji,jj,jl) 1181 1182 ! Total non solar heat flux sensitivity for ice 1183 dqns_ice(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + dqla_ice(ji,jj,jl) ) !#LB: correct signs ???? 1184 1185 END_2D 1108 1186 ! 1109 1187 END DO … … 1157 1235 ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm 1158 1236 DO jl = 1, jpl 1159 WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm 1237 WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm 1160 1238 qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) 1161 1239 ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm 1162 1240 qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:) 1163 1241 ELSEWHERE ! zero when hs>0 1164 qtr_ice_top(:,:,jl) = 0._wp 1242 qtr_ice_top(:,:,jl) = 0._wp 1165 1243 END WHERE 1166 1244 ENDDO … … 1201 1279 CALL prt_ctl(tab2d_1=tprecip , clinfo1=' blk_ice: tprecip : ', tab2d_2=sprecip , clinfo2=' sprecip : ') 1202 1280 ENDIF 1203 ! 1281 1282 !#LB: 1283 ! air-ice heat flux components that are not written from ice_stp()@icestp.F90: 1284 IF( iom_use('qla_ice') ) CALL iom_put( 'qla_ice', SUM( - qla_ice * a_i_b, dim=3 ) ) !#LB: sign consistent with what's done for ocean 1285 IF( iom_use('qsb_ice') ) CALL iom_put( 'qsb_ice', SUM( - z_qsb * a_i_b, dim=3 ) ) !#LB: ==> negative => loss of heat for sea-ice 1286 IF( iom_use('qlw_ice') ) CALL iom_put( 'qlw_ice', SUM( z_qlw * a_i_b, dim=3 ) ) 1287 !#LB. 1288 1204 1289 END SUBROUTINE blk_ice_2 1205 1290 … … 1254 1339 DO jl = 1, jpl 1255 1340 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 1256 1257 1341 zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcnd_i * phs(ji,jj,jl) ) * zfac ! Effective thickness 1342 IF( zhe >= zfac2 ) zgfac(ji,jj,jl) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( zhe * zfac3 ) ) ) ! Enhanced conduction factor 1258 1343 END_2D 1259 1344 END DO … … 1269 1354 DO jl = 1, jpl 1270 1355 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1356 ! 1357 zkeff_h = zfac * zgfac(ji,jj,jl) / & ! Effective conductivity of the snow-ice system divided by thickness 1358 & ( rcnd_i * phs(ji,jj,jl) + rn_cnd_s * MAX( 0.01, phi(ji,jj,jl) ) ) 1359 ztsu = ptsu(ji,jj,jl) ! Store current iteration temperature 1360 ztsu0 = ptsu(ji,jj,jl) ! Store initial surface temperature 1361 zqa0 = qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) ! Net initial atmospheric heat flux 1362 ! 1363 DO iter = 1, nit ! --- Iterative loop 1364 zqc = zkeff_h * ( ztsu - ptb(ji,jj) ) ! Conduction heat flux through snow-ice system (>0 downwards) 1365 zqnet = zqa0 + dqns_ice(ji,jj,jl) * ( ztsu - ptsu(ji,jj,jl) ) - zqc ! Surface energy budget 1366 ztsu = ztsu - zqnet / ( dqns_ice(ji,jj,jl) - zkeff_h ) ! Temperature update 1367 END DO 1368 ! 1369 ptsu (ji,jj,jl) = MIN( rt0, ztsu ) 1370 qcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) ) 1371 qns_ice(ji,jj,jl) = qns_ice(ji,jj,jl) + dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) 1372 qml_ice(ji,jj,jl) = ( qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) - qcn_ice(ji,jj,jl) ) & 1373 & * MAX( 0._wp , SIGN( 1._wp, ptsu(ji,jj,jl) - rt0 ) ) 1374 1375 ! --- Diagnose the heat loss due to changing non-solar flux (as in icethd_zdf_bl99) --- ! 1376 hfx_err_dif(ji,jj) = hfx_err_dif(ji,jj) - ( dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) ) * a_i_b(ji,jj,jl) 1292 1377 1293 1378 END_2D … … 1296 1381 ! 1297 1382 END SUBROUTINE blk_ice_qcn 1298 1299 1300 SUBROUTINE Cdn10_Lupkes2012( pcd )1301 !!----------------------------------------------------------------------1302 !! *** ROUTINE Cdn10_Lupkes2012 ***1303 !!1304 !! ** Purpose : Recompute the neutral air-ice drag referenced at 10m1305 !! to make it dependent on edges at leads, melt ponds and flows.1306 !! After some approximations, this can be resumed to a dependency1307 !! on ice concentration.1308 !!1309 !! ** Method : The parameterization is taken from Lupkes et al. (2012) eq.(50)1310 !! with the highest level of approximation: level4, eq.(59)1311 !! The generic drag over a cell partly covered by ice can be re-written as follows:1312 !!1313 !! Cd = Cdw * (1-A) + Cdi * A + Ce * (1-A)**(nu+1/(10*beta)) * A**mu1314 !!1315 !! Ce = 2.23e-3 , as suggested by Lupkes (eq. 59)1316 !! nu = mu = beta = 1 , as suggested by Lupkes (eq. 59)1317 !! A is the concentration of ice minus melt ponds (if any)1318 !!1319 !! This new drag has a parabolic shape (as a function of A) starting at1320 !! Cdw(say 1.5e-3) for A=0, reaching 1.97e-3 for A~0.51321 !! and going down to Cdi(say 1.4e-3) for A=11322 !!1323 !! It is theoretically applicable to all ice conditions (not only MIZ)1324 !! => see Lupkes et al (2013)1325 !!1326 !! ** References : Lupkes et al. JGR 2012 (theory)1327 !! Lupkes et al. GRL 2013 (application to GCM)1328 !!1329 !!----------------------------------------------------------------------1330 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pcd1331 REAL(wp), PARAMETER :: zCe = 2.23e-03_wp1332 REAL(wp), PARAMETER :: znu = 1._wp1333 REAL(wp), PARAMETER :: zmu = 1._wp1334 REAL(wp), PARAMETER :: zbeta = 1._wp1335 REAL(wp) :: zcoef1336 !!----------------------------------------------------------------------1337 zcoef = znu + 1._wp / ( 10._wp * zbeta )1338 1339 ! generic drag over a cell partly covered by ice1340 !!Cd(:,:) = Cd_oce(:,:) * ( 1._wp - at_i_b(:,:) ) + & ! pure ocean drag1341 !! & Cd_ice * at_i_b(:,:) + & ! pure ice drag1342 !! & zCe * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**zmu ! change due to sea-ice morphology1343 1344 ! ice-atm drag1345 pcd(:,:) = rCd_ice + & ! pure ice drag1346 & zCe * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**(zmu-1._wp) ! change due to sea-ice morphology1347 1348 END SUBROUTINE Cdn10_Lupkes20121349 1350 1351 SUBROUTINE Cdn10_Lupkes2015( ptm_su, pslp, pcd, pch )1352 !!----------------------------------------------------------------------1353 !! *** ROUTINE Cdn10_Lupkes2015 ***1354 !!1355 !! ** pUrpose : Alternative turbulent transfert coefficients formulation1356 !! between sea-ice and atmosphere with distinct momentum1357 !! and heat coefficients depending on sea-ice concentration1358 !! and atmospheric stability (no meltponds effect for now).1359 !!1360 !! ** Method : The parameterization is adapted from Lupkes et al. (2015)1361 !! and ECHAM6 atmospheric model. Compared to Lupkes2012 scheme,1362 !! it considers specific skin and form drags (Andreas et al. 2010)1363 !! to compute neutral transfert coefficients for both heat and1364 !! momemtum fluxes. Atmospheric stability effect on transfert1365 !! coefficient is also taken into account following Louis (1979).1366 !!1367 !! ** References : Lupkes et al. JGR 2015 (theory)1368 !! Lupkes et al. ECHAM6 documentation 2015 (implementation)1369 !!1370 !!----------------------------------------------------------------------1371 !1372 REAL(wp), DIMENSION(:,:), INTENT(in ) :: ptm_su ! sea-ice surface temperature [K]1373 REAL(wp), DIMENSION(:,:), INTENT(in ) :: pslp ! sea-level pressure [Pa]1374 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pcd ! momentum transfert coefficient1375 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pch ! heat transfert coefficient1376 REAL(wp), DIMENSION(jpi,jpj) :: zst, zqo_sat, zqi_sat1377 !1378 ! ECHAM6 constants1379 REAL(wp), PARAMETER :: z0_skin_ice = 0.69e-3_wp ! Eq. 43 [m]1380 REAL(wp), PARAMETER :: z0_form_ice = 0.57e-3_wp ! Eq. 42 [m]1381 REAL(wp), PARAMETER :: z0_ice = 1.00e-3_wp ! Eq. 15 [m]1382 REAL(wp), PARAMETER :: zce10 = 2.80e-3_wp ! Eq. 411383 REAL(wp), PARAMETER :: zbeta = 1.1_wp ! Eq. 411384 REAL(wp), PARAMETER :: zc = 5._wp ! Eq. 131385 REAL(wp), PARAMETER :: zc2 = zc * zc1386 REAL(wp), PARAMETER :: zam = 2. * zc ! Eq. 141387 REAL(wp), PARAMETER :: zah = 3. * zc ! Eq. 301388 REAL(wp), PARAMETER :: z1_alpha = 1._wp / 0.2_wp ! Eq. 511389 REAL(wp), PARAMETER :: z1_alphaf = z1_alpha ! Eq. 561390 REAL(wp), PARAMETER :: zbetah = 1.e-3_wp ! Eq. 261391 REAL(wp), PARAMETER :: zgamma = 1.25_wp ! Eq. 261392 REAL(wp), PARAMETER :: z1_gamma = 1._wp / zgamma1393 REAL(wp), PARAMETER :: r1_3 = 1._wp / 3._wp1394 !1395 INTEGER :: ji, jj ! dummy loop indices1396 REAL(wp) :: zthetav_os, zthetav_is, zthetav_zu1397 REAL(wp) :: zrib_o, zrib_i1398 REAL(wp) :: zCdn_skin_ice, zCdn_form_ice, zCdn_ice1399 REAL(wp) :: zChn_skin_ice, zChn_form_ice1400 REAL(wp) :: z0w, z0i, zfmi, zfmw, zfhi, zfhw1401 REAL(wp) :: zCdn_form_tmp1402 !!----------------------------------------------------------------------1403 1404 ! Momentum Neutral Transfert Coefficients (should be a constant)1405 zCdn_form_tmp = zce10 * ( LOG( 10._wp / z0_form_ice + 1._wp ) / LOG( rn_zu / z0_form_ice + 1._wp ) )**2 ! Eq. 401406 zCdn_skin_ice = ( vkarmn / LOG( rn_zu / z0_skin_ice + 1._wp ) )**2 ! Eq. 71407 zCdn_ice = zCdn_skin_ice ! Eq. 71408 !zCdn_ice = 1.89e-3 ! old ECHAM5 value (cf Eq. 32)1409 1410 ! Heat Neutral Transfert Coefficients1411 zChn_skin_ice = vkarmn**2 / ( LOG( rn_zu / z0_ice + 1._wp ) * LOG( rn_zu * z1_alpha / z0_skin_ice + 1._wp ) ) ! Eq. 50 + Eq. 521412 1413 ! Atmospheric and Surface Variables1414 zst(:,:) = sst_m(:,:) + rt0 ! convert SST from Celcius to Kelvin1415 zqo_sat(:,:) = rdct_qsat_salt * q_sat( zst(:,:) , pslp(:,:) ) ! saturation humidity over ocean [kg/kg]1416 zqi_sat(:,:) = q_sat( ptm_su(:,:), pslp(:,:) ) ! saturation humidity over ice [kg/kg]1417 !1418 DO_2D( 0, 0, 0, 0 )1419 ! Virtual potential temperature [K]1420 zthetav_os = zst(ji,jj) * ( 1._wp + rctv0 * zqo_sat(ji,jj) ) ! over ocean1421 zthetav_is = ptm_su(ji,jj) * ( 1._wp + rctv0 * zqi_sat(ji,jj) ) ! ocean ice1422 zthetav_zu = t_zu (ji,jj) * ( 1._wp + rctv0 * q_zu(ji,jj) ) ! at zu1423 1424 ! Bulk Richardson Number (could use Ri_bulk function from aerobulk instead)1425 zrib_o = grav / zthetav_os * ( zthetav_zu - zthetav_os ) * rn_zu / MAX( 0.5, wndm(ji,jj) )**2 ! over ocean1426 zrib_i = grav / zthetav_is * ( zthetav_zu - zthetav_is ) * rn_zu / MAX( 0.5, wndm_ice(ji,jj) )**2 ! over ice1427 1428 ! Momentum and Heat Neutral Transfert Coefficients1429 zCdn_form_ice = zCdn_form_tmp * at_i_b(ji,jj) * ( 1._wp - at_i_b(ji,jj) )**zbeta ! Eq. 401430 zChn_form_ice = zCdn_form_ice / ( 1._wp + ( LOG( z1_alphaf ) / vkarmn ) * SQRT( zCdn_form_ice ) ) ! Eq. 531431 1432 ! Momentum and Heat Stability functions (possibility to use psi_m_ecmwf instead ?)1433 z0w = rn_zu * EXP( -1._wp * vkarmn / SQRT( Cdn_oce(ji,jj) ) ) ! over water1434 z0i = z0_skin_ice ! over ice1435 IF( zrib_o <= 0._wp ) THEN1436 zfmw = 1._wp - zam * zrib_o / ( 1._wp + 3._wp * zc2 * Cdn_oce(ji,jj) * SQRT( -zrib_o * ( rn_zu / z0w + 1._wp ) ) ) ! Eq. 101437 zfhw = ( 1._wp + ( zbetah * ( zthetav_os - zthetav_zu )**r1_3 / ( Chn_oce(ji,jj) * MAX(0.01, wndm(ji,jj)) ) & ! Eq. 261438 & )**zgamma )**z1_gamma1439 ELSE1440 zfmw = 1._wp / ( 1._wp + zam * zrib_o / SQRT( 1._wp + zrib_o ) ) ! Eq. 121441 zfhw = 1._wp / ( 1._wp + zah * zrib_o / SQRT( 1._wp + zrib_o ) ) ! Eq. 281442 ENDIF1443 1444 IF( zrib_i <= 0._wp ) THEN1445 zfmi = 1._wp - zam * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp))) ! Eq. 91446 zfhi = 1._wp - zah * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp))) ! Eq. 251447 ELSE1448 zfmi = 1._wp / ( 1._wp + zam * zrib_i / SQRT( 1._wp + zrib_i ) ) ! Eq. 111449 zfhi = 1._wp / ( 1._wp + zah * zrib_i / SQRT( 1._wp + zrib_i ) ) ! Eq. 271450 ENDIF1451 1452 ! Momentum Transfert Coefficients (Eq. 38)1453 pcd(ji,jj) = zCdn_skin_ice * zfmi + &1454 & zCdn_form_ice * ( zfmi * at_i_b(ji,jj) + zfmw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) )1455 1456 ! Heat Transfert Coefficients (Eq. 49)1457 pch(ji,jj) = zChn_skin_ice * zfhi + &1458 & zChn_form_ice * ( zfhi * at_i_b(ji,jj) + zfhw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) )1459 !1460 END_2D1461 CALL lbc_lnk_multi( 'sbcblk', pcd, 'T', 1.0_wp, pch, 'T', 1.0_wp )1462 !1463 END SUBROUTINE Cdn10_Lupkes20151464 1383 1465 1384 #endif -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/SBC/sbcblk_algo_coare3p0.F90
r13460 r13655 7 7 !! * bulk transfer coefficients C_D, C_E and C_H 8 8 !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed 9 !! * the effective bulk wind speed at 10m U _blk9 !! * the effective bulk wind speed at 10m Ubzu 10 10 !! => all these are used in bulk formulas in sbcblk.F90 11 11 !! … … 37 37 38 38 USE sbc_oce ! Surface boundary condition: ocean fields 39 USE sbc blk_phy! all thermodynamics functions, rho_air, q_sat, etc... !LB39 USE sbc_phy ! all thermodynamics functions, rho_air, q_sat, etc... !LB 40 40 USE sbcblk_skin_coare ! cool-skin/warm layer scheme (CSWL_ECMWF) !LB 41 41 … … 50 50 REAL(wp), PARAMETER :: zi0 = 600._wp ! scale height of the atmospheric boundary layer... 51 51 REAL(wp), PARAMETER :: Beta0 = 1.25_wp ! gustiness parameter 52 53 INTEGER , PARAMETER :: nb_itt = 10 ! number of itterations 52 REAL(wp), PARAMETER :: zeta_abs_max = 50._wp 54 53 55 54 !!---------------------------------------------------------------------- … … 90 89 91 90 SUBROUTINE turb_coare3p0( kt, zt, zu, T_s, t_zt, q_s, q_zt, U_zu, l_use_cs, l_use_wl, & 92 & Cd, Ch, Ce, t_zu, q_zu, U _blk,&93 & Cdn, Chn, Cen, &91 & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & 92 & nb_iter, Cdn, Chn, Cen, & ! optional output 94 93 & Qsw, rad_lw, slp, pdT_cs, & ! optionals for cool-skin (and warm-layer) 95 & pdT_wl, pHz_wl ) 94 & pdT_wl, pHz_wl ) ! optionals for warm-layer only 96 95 !!---------------------------------------------------------------------- 97 96 !! *** ROUTINE turb_coare3p0 *** … … 147 146 !! * t_zu : pot. air temperature adjusted at wind height zu [K] 148 147 !! * q_zu : specific humidity of air // [kg/kg] 149 !! * U _blk: bulk wind speed at zu [m/s]148 !! * Ubzu : bulk wind speed at zu [m/s] 150 149 !! 151 150 !! … … 167 166 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] 168 167 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] 169 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: U_blk ! bulk wind speed at zu [m/s] 170 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cdn, Chn, Cen ! neutral transfer coefficients 171 ! 168 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] 169 ! 170 INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations 171 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN 172 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN 173 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN 172 174 REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] 173 175 REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] … … 177 179 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] 178 180 ! 179 INTEGER :: j_itt181 INTEGER :: nbit, jit 180 182 LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U 181 183 ! … … 194 196 IF( kt == nit000 ) CALL SBCBLK_ALGO_COARE3P0_INIT(l_use_cs, l_use_wl) 195 197 198 nbit = nb_iter0 199 IF( PRESENT(nb_iter) ) nbit = nb_iter 200 196 201 l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision 197 202 IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) … … 211 216 ENDIF 212 217 213 214 218 !! First guess of temperature and humidity at height zu: 215 219 t_zu = MAX( t_zt , 180._wp ) ! who knows what's given on masked-continental regions... … … 222 226 znu_a = visc_air(t_zu) ! Air viscosity (m^2/s) at zt given from temperature in (K) 223 227 224 U _blk= SQRT(U_zu*U_zu + 0.5_wp*0.5_wp) ! initial guess for wind gustiness contribution228 Ubzu = SQRT(U_zu*U_zu + 0.5_wp*0.5_wp) ! initial guess for wind gustiness contribution 225 229 226 230 ztmp0 = LOG( zu*10000._wp) ! optimization: 10000. == 1/z0 (with z0 first guess == 0.0001) 227 231 ztmp1 = LOG(10._wp*10000._wp) ! " " " 228 u_star = 0.035_wp*U _blk*ztmp1/ztmp0 ! (u* = 0.035*Un10)229 230 z0 = alfa_charn_3p0(U_zu)*u_star*u_star/grav + 0.11_wp*znu_a/u_star232 u_star = 0.035_wp*Ubzu*ztmp1/ztmp0 ! (u* = 0.035*Un10) 233 234 z0 = charn_coare3p0(U_zu)*u_star*u_star/grav + 0.11_wp*znu_a/u_star 231 235 z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) 232 236 … … 234 238 z0t = MIN( MAX(ABS(z0t), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) 235 239 236 Cd = (vkarmn/ztmp0)**2! first guess of Cd237 238 ztmp0 = vkarmn *vkarmn/LOG(zt/z0t)/Cd239 240 ztmp2 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, U _blk) ! Bulk Richardson Number (BRN)240 Cd = MAX( (vkarmn/ztmp0)**2 , Cx_min ) ! first guess of Cd 241 242 ztmp0 = vkarmn2/LOG(zt/z0t)/Cd 243 244 ztmp2 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, Ubzu ) ! Bulk Richardson Number (BRN) 241 245 242 246 !! First estimate of zeta_u, depending on the stability, ie sign of BRN (ztmp2): 243 247 ztmp1 = 0.5 + SIGN( 0.5_wp , ztmp2 ) 244 ztmp0 = ztmp0*ztmp2 245 zeta_u = (1._wp-ztmp1) * (ztmp0/(1._wp+ztmp2/(-zu/(zi0*0.004_wp*Beta0**3)))) & ! BRN < 0 246 & + ztmp1 * (ztmp0*(1._wp + 27._wp/9._wp*ztmp2/ztmp0)) ! BRN > 0 247 !#LB: should make sure that the "ztmp0" of "27./9.*ztmp2/ztmp0" is "ztmp0*ztmp2" and not "ztmp0==vkarmn*vkarmn/LOG(zt/z0t)/Cd" ! 248 248 zeta_u = (1._wp - ztmp1) * ztmp0*ztmp2 / (1._wp - ztmp2*zi0*0.004_wp*Beta0**3/zu) & ! BRN < 0 249 & + ztmp1 * ( ztmp0*ztmp2 + 27._wp/9._wp*ztmp2*ztmp2 ) ! BRN > 0 250 249 251 !! First guess M-O stability dependent scaling params.(u*,t*,q*) to estimate z0 and z/L 250 252 ztmp0 = vkarmn/(LOG(zu/z0t) - psi_h_coare(zeta_u)) 251 253 252 u_star = MAX ( U _blk*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on)254 u_star = MAX ( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) 253 255 t_star = dt_zu*ztmp0 254 256 q_star = dq_zu*ztmp0 … … 269 271 270 272 !! ITERATION BLOCK 271 DO j _itt = 1, nb_itt272 273 !!Inverse of Monin-Obukov length (1/L) :274 ztmp0 = One_on_L(t_zu, q_zu, u_star, t_star, q_star) ! 1/L == 1/[ Monin-Obukhov length]275 ztmp0 = SIGN( MIN(ABS(ztmp0),200._wp), ztmp0 ) ! (prevents FPE from stupid values from masked region later on...)273 DO jit = 1, nbit 274 275 !!Inverse of Obukov length (1/L) : 276 ztmp0 = One_on_L(t_zu, q_zu, u_star, t_star, q_star) ! 1/L == 1/[Obukhov length] 277 ztmp0 = SIGN( MIN(ABS(ztmp0),200._wp), ztmp0 ) ! 1/L (prevents FPE from stupid values from masked region later on...) 276 278 277 279 ztmp1 = u_star*u_star ! u*^2 … … 280 282 ztmp2 = Beta0*Beta0*ztmp1*(MAX(-zi0*ztmp0/vkarmn,0._wp))**(2._wp/3._wp) ! square of wind gustiness contribution, ztmp2 == Ug^2 281 283 !! ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before zi0 282 U _blk= MAX(SQRT(U_zu*U_zu + ztmp2), 0.2_wp) ! include gustiness in bulk wind speed283 ! => 0.2 prevents U _blkto be 0 in stable case when U_zu=0.284 Ubzu = MAX(SQRT(U_zu*U_zu + ztmp2), 0.2_wp) ! include gustiness in bulk wind speed 285 ! => 0.2 prevents Ubzu to be 0 in stable case when U_zu=0. 284 286 285 287 !! Stability parameters: 286 288 zeta_u = zu*ztmp0 287 zeta_u = SIGN( MIN(ABS(zeta_u), 50.0_wp), zeta_u )289 zeta_u = SIGN( MIN(ABS(zeta_u),zeta_abs_max), zeta_u ) 288 290 IF( .NOT. l_zt_equal_zu ) THEN 289 291 zeta_t = zt*ztmp0 290 zeta_t = SIGN( MIN(ABS(zeta_t), 50.0_wp), zeta_t )292 zeta_t = SIGN( MIN(ABS(zeta_t),zeta_abs_max), zeta_t ) 291 293 ENDIF 292 294 … … 296 298 !! Roughness lengthes z0, z0t (z0q = z0t) : 297 299 ztmp2 = u_star/vkarmn*LOG(10./z0) ! Neutral wind speed at 10m 298 z0 = alfa_charn_3p0(ztmp2)*ztmp1/grav + 0.11_wp*znu_a/u_star ! Roughness length (eq.6) [ ztmp1==u*^2 ]300 z0 = charn_coare3p0(ztmp2)*ztmp1/grav + 0.11_wp*znu_a/u_star ! Roughness length (eq.6) [ ztmp1==u*^2 ] 299 301 z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) 300 302 … … 309 311 t_star = dt_zu*ztmp1 310 312 q_star = dq_zu*ztmp1 311 u_star = MAX( U _blk*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on)313 u_star = MAX( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) 312 314 313 315 IF( .NOT. l_zt_equal_zu ) THEN … … 318 320 ENDIF 319 321 320 321 322 IF( l_use_cs ) THEN 322 323 !! Cool-skin contribution 323 324 324 CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, U _blk, slp, rad_lw, &325 CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, & 325 326 & ztmp1, zeta_u, Qlat=ztmp2) ! Qnsol -> ztmp1 / Tau -> zeta_u 326 327 … … 330 331 IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1) 331 332 q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) 332 333 333 ENDIF 334 334 335 335 IF( l_use_wl ) THEN 336 336 !! Warm-layer contribution 337 CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, U _blk, slp, rad_lw, &337 CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, & 338 338 & ztmp1, zeta_u) ! Qnsol -> ztmp1 / Tau -> zeta_u 339 339 !! In WL_COARE or , Tau_ac and Qnt_ac must be updated at the final itteration step => add a flag to do this! 340 CALL WL_COARE( Qsw, ztmp1, zeta_u, zsst, MOD(nb _itt,j_itt) )340 CALL WL_COARE( Qsw, ztmp1, zeta_u, zsst, MOD(nbit,jit) ) 341 341 342 342 !! Updating T_s and q_s !!! … … 351 351 ENDIF 352 352 353 END DO !DO j _itt = 1, nb_itt353 END DO !DO jit = 1, nbit 354 354 355 355 ! compute transfer coefficients at zu : 356 ztmp0 = u_star/U_blk 357 Cd = ztmp0*ztmp0 358 Ch = ztmp0*t_star/dt_zu 359 Ce = ztmp0*q_star/dq_zu 360 361 ztmp1 = zu + z0 362 Cdn = vkarmn*vkarmn / (log(ztmp1/z0 )*log(ztmp1/z0 )) 363 Chn = vkarmn*vkarmn / (log(ztmp1/z0t)*log(ztmp1/z0t)) 364 Cen = Chn 356 ztmp0 = u_star/Ubzu 357 Cd = MAX( ztmp0*ztmp0 , Cx_min ) 358 Ch = MAX( ztmp0*t_star/dt_zu , Cx_min ) 359 Ce = MAX( ztmp0*q_star/dq_zu , Cx_min ) 365 360 366 361 IF( .NOT. l_zt_equal_zu ) DEALLOCATE( zeta_t ) 362 363 IF(PRESENT(Cdn)) Cdn = MAX( vkarmn2 / (LOG(zu/z0 )*LOG(zu/z0 )) , Cx_min ) 364 IF(PRESENT(Chn)) Chn = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) 365 IF(PRESENT(Cen)) Cen = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) 367 366 368 367 IF( l_use_cs .AND. PRESENT(pdT_cs) ) pdT_cs = dT_cs … … 375 374 376 375 377 FUNCTION alfa_charn_3p0( pwnd )376 FUNCTION charn_coare3p0( pwnd ) 378 377 !!------------------------------------------------------------------- 379 378 !! Compute the Charnock parameter as a function of the wind speed … … 387 386 !! Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) 388 387 !!------------------------------------------------------------------- 389 REAL(wp), DIMENSION(jpi,jpj) :: alfa_charn_3p0388 REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p0 390 389 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed 391 390 ! … … 393 392 REAL(wp) :: zw, zgt10, zgt18 394 393 !!------------------------------------------------------------------- 395 !396 394 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 397 !398 zw = pwnd(ji,jj) ! wind speed399 !400 ! Charnock's constant, increases with the wind :401 zgt10 = 0.5 + SIGN(0.5_wp,(zw - 10)) ! If zw<10. --> 0, else --> 1402 zgt18 = 0.5 + SIGN(0.5_wp,(zw - 18.)) ! If zw<18. --> 0, else --> 1403 !404 alfa_charn_3p0(ji,jj) = (1. - zgt10)*0.011 & ! wind is lower than 10 m/s405 & + zgt10*((1. - zgt18)*(0.011 + (0.018 - 0.011) &406 & *(zw - 10.)/(18. - 10.)) + zgt18*( 0.018 ) ) ! Hare et al. (1999)407 !395 ! 396 zw = pwnd(ji,jj) ! wind speed 397 ! 398 ! Charnock's constant, increases with the wind : 399 zgt10 = 0.5 + SIGN(0.5_wp,(zw - 10)) ! If zw<10. --> 0, else --> 1 400 zgt18 = 0.5 + SIGN(0.5_wp,(zw - 18.)) ! If zw<18. --> 0, else --> 1 401 ! 402 charn_coare3p0(ji,jj) = (1. - zgt10)*0.011 & ! wind is lower than 10 m/s 403 & + zgt10*((1. - zgt18)*(0.011 + (0.018 - 0.011) & 404 & *(zw - 10.)/(18. - 10.)) + zgt18*( 0.018 ) ) ! Hare et al. (1999) 405 ! 408 406 END_2D 409 ! 410 END FUNCTION alfa_charn_3p0 407 END FUNCTION charn_coare3p0 411 408 412 409 FUNCTION psi_m_coare( pzeta ) … … 429 426 REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab 430 427 !!---------------------------------------------------------------------------------- 431 !432 428 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 433 ! 434 zta = pzeta(ji,jj) 435 ! 436 zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable 437 ! 438 zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) & 439 & - 2.*ATAN(zphi_m) + 0.5*rpi 440 ! 441 zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective 442 ! 443 zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 444 & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 445 ! 446 zf = zta*zta 447 zf = zf/(1. + zf) 448 zc = MIN(50._wp, 0.35_wp*zta) 449 zstab = 0.5 + SIGN(0.5_wp, zta) 450 ! 451 psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) 452 & - zstab * ( 1. + 1.*zta & ! (zta > 0) 453 & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! " 454 ! 429 ! 430 zta = pzeta(ji,jj) 431 ! 432 zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable 433 ! 434 zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) & 435 & - 2.*ATAN(zphi_m) + 0.5*rpi 436 ! 437 zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective 438 ! 439 zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 440 & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 441 ! 442 zf = zta*zta 443 zf = zf/(1. + zf) 444 zc = MIN(50._wp, 0.35_wp*zta) 445 zstab = 0.5 + SIGN(0.5_wp, zta) 446 ! 447 psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) 448 & - zstab * ( 1. + 1.*zta & ! (zta > 0) 449 & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! " 455 450 END_2D 456 !457 451 END FUNCTION psi_m_coare 458 452 … … 474 468 !! (https://github.com/brodeau/aerobulk/) 475 469 !!---------------------------------------------------------------- 476 !!477 470 REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare 478 471 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta … … 480 473 INTEGER :: ji, jj ! dummy loop indices 481 474 REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab 482 ! 475 !!---------------------------------------------------------------- 483 476 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 484 ! 485 zta = pzeta(ji,jj) 486 ! 487 zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable) 488 ! 489 zpsi_k = 2.*LOG((1. + zphi_h)/2.) 490 ! 491 zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective 492 ! 493 zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 494 & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 495 ! 496 zf = zta*zta 497 zf = zf/(1. + zf) 498 zc = MIN(50._wp,0.35_wp*zta) 499 zstab = 0.5 + SIGN(0.5_wp, zta) 500 ! 501 psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & 502 & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 & 503 & + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) 504 ! 477 ! 478 zta = pzeta(ji,jj) 479 ! 480 zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable) 481 ! 482 zpsi_k = 2.*LOG((1. + zphi_h)/2.) 483 ! 484 zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective 485 ! 486 zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 487 & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 488 ! 489 zf = zta*zta 490 zf = zf/(1. + zf) 491 zc = MIN(50._wp,0.35_wp*zta) 492 zstab = 0.5 + SIGN(0.5_wp, zta) 493 ! 494 psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & 495 & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 & 496 & + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) 505 497 END_2D 506 !507 498 END FUNCTION psi_h_coare 508 499 -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/SBC/sbcblk_algo_coare3p6.F90
r13460 r13655 7 7 !! * bulk transfer coefficients C_D, C_E and C_H 8 8 !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed 9 !! * the effective bulk wind speed at 10m U _blk9 !! * the effective bulk wind speed at 10m Ubzu 10 10 !! => all these are used in bulk formulas in sbcblk.F90 11 11 !! … … 23 23 !! returns the effective bulk wind speed at 10m 24 24 !!---------------------------------------------------------------------- 25 USE oce ! ocean dynamics and tracers26 25 USE dom_oce ! ocean space and time domain 27 26 USE phycst ! physical constants 28 USE iom ! I/O manager library 29 USE lib_mpp ! distribued memory computing library 30 USE in_out_manager ! I/O manager 31 USE prtctl ! Print control 32 USE sbcwave, ONLY : cdn_wave ! wave module 33 #if defined key_si3 || defined key_cice 34 USE sbc_ice ! Surface boundary condition: ice fields 35 #endif 36 USE lib_fortran ! to use key_nosignedzero 37 38 USE sbc_oce ! Surface boundary condition: ocean fields 39 USE sbcblk_phy ! all thermodynamics functions, rho_air, q_sat, etc... !LB 27 USE lib_mpp, ONLY: ctl_stop ! distribued memory computing library 28 USE in_out_manager, ONLY: nit000 ! I/O manager 29 USE sbc_phy ! all thermodynamics functions, rho_air, q_sat, etc... !LB 40 30 USE sbcblk_skin_coare ! cool-skin/warm layer scheme (CSWL_ECMWF) !LB 41 31 … … 50 40 REAL(wp), PARAMETER :: zi0 = 600._wp ! scale height of the atmospheric boundary layer... 51 41 REAL(wp), PARAMETER :: Beta0 = 1.2_wp ! gustiness parameter 52 53 INTEGER , PARAMETER :: nb_itt = 10 ! number of itterations 42 REAL(wp), PARAMETER :: zeta_abs_max = 50._wp 54 43 55 44 !!---------------------------------------------------------------------- … … 90 79 91 80 SUBROUTINE turb_coare3p6( kt, zt, zu, T_s, t_zt, q_s, q_zt, U_zu, l_use_cs, l_use_wl, & 92 & Cd, Ch, Ce, t_zu, q_zu, U _blk,&93 & Cdn, Chn, Cen, &81 & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & 82 & nb_iter, Cdn, Chn, Cen, & ! optional output 94 83 & Qsw, rad_lw, slp, pdT_cs, & ! optionals for cool-skin (and warm-layer) 95 & pdT_wl, pHz_wl ) 84 & pdT_wl, pHz_wl ) ! optionals for warm-layer only 96 85 !!---------------------------------------------------------------------- 97 86 !! *** ROUTINE turb_coare3p6 *** … … 147 136 !! * t_zu : pot. air temperature adjusted at wind height zu [K] 148 137 !! * q_zu : specific humidity of air // [kg/kg] 149 !! * U _blk: bulk wind speed at zu [m/s]138 !! * Ubzu : bulk wind speed at zu [m/s] 150 139 !! 151 140 !! … … 167 156 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] 168 157 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] 169 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: U_blk ! bulk wind speed at zu [m/s] 170 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cdn, Chn, Cen ! neutral transfer coefficients 171 ! 158 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] 159 ! 160 INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations 161 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN 162 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN 163 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN 172 164 REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] 173 165 REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] … … 177 169 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] 178 170 ! 179 INTEGER :: j_itt171 INTEGER :: nbit, jit 180 172 LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U 181 173 ! … … 194 186 IF( kt == nit000 ) CALL SBCBLK_ALGO_COARE3P6_INIT(l_use_cs, l_use_wl) 195 187 188 nbit = nb_iter0 189 IF( PRESENT(nb_iter) ) nbit = nb_iter 190 196 191 l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision 197 192 IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) … … 211 206 ENDIF 212 207 213 214 208 !! First guess of temperature and humidity at height zu: 215 209 t_zu = MAX( t_zt , 180._wp ) ! who knows what's given on masked-continental regions... … … 222 216 znu_a = visc_air(t_zu) ! Air viscosity (m^2/s) at zt given from temperature in (K) 223 217 224 U _blk= SQRT(U_zu*U_zu + 0.5_wp*0.5_wp) ! initial guess for wind gustiness contribution218 Ubzu = SQRT(U_zu*U_zu + 0.5_wp*0.5_wp) ! initial guess for wind gustiness contribution 225 219 226 220 ztmp0 = LOG( zu*10000._wp) ! optimization: 10000. == 1/z0 (with z0 first guess == 0.0001) 227 221 ztmp1 = LOG(10._wp*10000._wp) ! " " " 228 u_star = 0.035_wp*U _blk*ztmp1/ztmp0 ! (u* = 0.035*Un10)229 230 z0 = alfa_charn_3p6(U_zu)*u_star*u_star/grav + 0.11_wp*znu_a/u_star222 u_star = 0.035_wp*Ubzu*ztmp1/ztmp0 ! (u* = 0.035*Un10) 223 224 z0 = charn_coare3p6(U_zu)*u_star*u_star/grav + 0.11_wp*znu_a/u_star 231 225 z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) 232 226 … … 234 228 z0t = MIN( MAX(ABS(z0t), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) 235 229 236 Cd = (vkarmn/ztmp0)**2! first guess of Cd237 238 ztmp0 = vkarmn *vkarmn/LOG(zt/z0t)/Cd239 240 ztmp2 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, U _blk) ! Bulk Richardson Number (BRN)230 Cd = MAX( (vkarmn/ztmp0)**2 , Cx_min ) ! first guess of Cd 231 232 ztmp0 = vkarmn2/LOG(zt/z0t)/Cd 233 234 ztmp2 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, Ubzu ) ! Bulk Richardson Number (BRN) 241 235 242 236 !! First estimate of zeta_u, depending on the stability, ie sign of BRN (ztmp2): 243 237 ztmp1 = 0.5 + SIGN( 0.5_wp , ztmp2 ) 244 ztmp0 = ztmp0*ztmp2 245 zeta_u = (1._wp-ztmp1) * (ztmp0/(1._wp+ztmp2/(-zu/(zi0*0.004_wp*Beta0**3)))) & ! BRN < 0 246 & + ztmp1 * (ztmp0*(1._wp + 27._wp/9._wp*ztmp2/ztmp0)) ! BRN > 0 247 !#LB: should make sure that the "ztmp0" of "27./9.*ztmp2/ztmp0" is "ztmp0*ztmp2" and not "ztmp0==vkarmn*vkarmn/LOG(zt/z0t)/Cd" ! 248 238 zeta_u = (1._wp - ztmp1) * ztmp0*ztmp2 / (1._wp - ztmp2*zi0*0.004_wp*Beta0**3/zu) & ! BRN < 0 239 & + ztmp1 * ( ztmp0*ztmp2 + 27._wp/9._wp*ztmp2*ztmp2 ) ! BRN > 0 240 249 241 !! First guess M-O stability dependent scaling params.(u*,t*,q*) to estimate z0 and z/L 250 242 ztmp0 = vkarmn/(LOG(zu/z0t) - psi_h_coare(zeta_u)) 251 243 252 u_star = MAX ( U _blk*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on)244 u_star = MAX ( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) 253 245 t_star = dt_zu*ztmp0 254 246 q_star = dq_zu*ztmp0 … … 269 261 270 262 !! ITERATION BLOCK 271 DO j _itt = 1, nb_itt272 273 !!Inverse of Monin-Obukov length (1/L) :274 ztmp0 = One_on_L(t_zu, q_zu, u_star, t_star, q_star) ! 1/L == 1/[ Monin-Obukhov length]275 ztmp0 = SIGN( MIN(ABS(ztmp0),200._wp), ztmp0 ) ! (prevents FPE from stupid values from masked region later on...)263 DO jit = 1, nbit 264 265 !!Inverse of Obukov length (1/L) : 266 ztmp0 = One_on_L(t_zu, q_zu, u_star, t_star, q_star) ! 1/L == 1/[Obukhov length] 267 ztmp0 = SIGN( MIN(ABS(ztmp0),200._wp), ztmp0 ) ! 1/L (prevents FPE from stupid values from masked region later on...) 276 268 277 269 ztmp1 = u_star*u_star ! u*^2 … … 280 272 ztmp2 = Beta0*Beta0*ztmp1*(MAX(-zi0*ztmp0/vkarmn,0._wp))**(2._wp/3._wp) ! square of wind gustiness contribution, ztmp2 == Ug^2 281 273 !! ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before zi0 282 U _blk= MAX(SQRT(U_zu*U_zu + ztmp2), 0.2_wp) ! include gustiness in bulk wind speed283 ! => 0.2 prevents U _blkto be 0 in stable case when U_zu=0.274 Ubzu = MAX(SQRT(U_zu*U_zu + ztmp2), 0.2_wp) ! include gustiness in bulk wind speed 275 ! => 0.2 prevents Ubzu to be 0 in stable case when U_zu=0. 284 276 285 277 !! Stability parameters: 286 278 zeta_u = zu*ztmp0 287 zeta_u = SIGN( MIN(ABS(zeta_u), 50.0_wp), zeta_u )279 zeta_u = SIGN( MIN(ABS(zeta_u),zeta_abs_max), zeta_u ) 288 280 IF( .NOT. l_zt_equal_zu ) THEN 289 281 zeta_t = zt*ztmp0 290 zeta_t = SIGN( MIN(ABS(zeta_t), 50.0_wp), zeta_t )282 zeta_t = SIGN( MIN(ABS(zeta_t),zeta_abs_max), zeta_t ) 291 283 ENDIF 292 284 … … 296 288 !! Roughness lengthes z0, z0t (z0q = z0t) : 297 289 ztmp2 = u_star/vkarmn*LOG(10./z0) ! Neutral wind speed at 10m 298 z0 = alfa_charn_3p6(ztmp2)*ztmp1/grav + 0.11_wp*znu_a/u_star ! Roughness length (eq.6) [ ztmp1==u*^2 ]290 z0 = charn_coare3p6(ztmp2)*ztmp1/grav + 0.11_wp*znu_a/u_star ! Roughness length (eq.6) [ ztmp1==u*^2 ] 299 291 z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) 300 292 … … 309 301 t_star = dt_zu*ztmp1 310 302 q_star = dq_zu*ztmp1 311 u_star = MAX( U _blk*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on)303 u_star = MAX( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) 312 304 313 305 IF( .NOT. l_zt_equal_zu ) THEN … … 318 310 ENDIF 319 311 320 321 312 IF( l_use_cs ) THEN 322 313 !! Cool-skin contribution 323 314 324 CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, U _blk, slp, rad_lw, &315 CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, & 325 316 & ztmp1, zeta_u, Qlat=ztmp2) ! Qnsol -> ztmp1 / Tau -> zeta_u 326 317 … … 330 321 IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1) 331 322 q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) 332 333 323 ENDIF 334 324 335 325 IF( l_use_wl ) THEN 336 326 !! Warm-layer contribution 337 CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, U _blk, slp, rad_lw, &327 CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, & 338 328 & ztmp1, zeta_u) ! Qnsol -> ztmp1 / Tau -> zeta_u 339 329 !! In WL_COARE or , Tau_ac and Qnt_ac must be updated at the final itteration step => add a flag to do this! 340 CALL WL_COARE( Qsw, ztmp1, zeta_u, zsst, MOD(nb _itt,j_itt) )330 CALL WL_COARE( Qsw, ztmp1, zeta_u, zsst, MOD(nbit,jit) ) 341 331 342 332 !! Updating T_s and q_s !!! … … 351 341 ENDIF 352 342 353 END DO !DO j _itt = 1, nb_itt343 END DO !DO jit = 1, nbit 354 344 355 345 ! compute transfer coefficients at zu : 356 ztmp0 = u_star/U_blk 357 Cd = ztmp0*ztmp0 358 Ch = ztmp0*t_star/dt_zu 359 Ce = ztmp0*q_star/dq_zu 360 361 ztmp1 = zu + z0 362 Cdn = vkarmn*vkarmn / (log(ztmp1/z0 )*log(ztmp1/z0 )) 363 Chn = vkarmn*vkarmn / (log(ztmp1/z0t)*log(ztmp1/z0t)) 364 Cen = Chn 346 ztmp0 = u_star/Ubzu 347 Cd = MAX( ztmp0*ztmp0 , Cx_min ) 348 Ch = MAX( ztmp0*t_star/dt_zu , Cx_min ) 349 Ce = MAX( ztmp0*q_star/dq_zu , Cx_min ) 365 350 366 351 IF( .NOT. l_zt_equal_zu ) DEALLOCATE( zeta_t ) 352 353 IF(PRESENT(Cdn)) Cdn = MAX( vkarmn2 / (LOG(zu/z0 )*LOG(zu/z0 )) , Cx_min ) 354 IF(PRESENT(Chn)) Chn = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) 355 IF(PRESENT(Cen)) Cen = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) 367 356 368 357 IF( l_use_cs .AND. PRESENT(pdT_cs) ) pdT_cs = dT_cs … … 375 364 376 365 377 FUNCTION alfa_charn_3p6( pwnd )366 FUNCTION charn_coare3p6( pwnd ) 378 367 !!------------------------------------------------------------------- 379 368 !! Computes the Charnock parameter as a function of the Neutral wind speed at 10m … … 383 372 !! Author: L. Brodeau, July 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) 384 373 !!------------------------------------------------------------------- 385 REAL(wp), DIMENSION(jpi,jpj) :: alfa_charn_3p6374 REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p6 386 375 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! neutral wind speed at 10m 387 376 ! 388 377 REAL(wp), PARAMETER :: charn0_max = 0.028 !: value above which the Charnock parameter levels off for winds > 18 m/s 389 378 !!------------------------------------------------------------------- 390 alfa_charn_3p6 = MAX( MIN( 0.0017_wp*pwnd - 0.005_wp , charn0_max) , 0._wp )391 !! 392 END FUNCTION alfa_charn_3p6393 394 FUNCTION alfa_charn_3p6_wave( pus, pwsh, pwps )379 charn_coare3p6 = MAX( MIN( 0.0017_wp*pwnd - 0.005_wp , charn0_max) , 0._wp ) 380 !! 381 END FUNCTION charn_coare3p6 382 383 FUNCTION charn_coare3p6_wave( pus, pwsh, pwps ) 395 384 !!------------------------------------------------------------------- 396 385 !! Computes the Charnock parameter as a function of wave information and u* … … 400 389 !! Author: L. Brodeau, October 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) 401 390 !!------------------------------------------------------------------- 402 REAL(wp), DIMENSION(jpi,jpj) :: alfa_charn_3p6_wave391 REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p6_wave 403 392 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! friction velocity [m/s] 404 393 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwsh ! significant wave height [m] 405 394 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwps ! phase speed of dominant waves [m/s] 406 395 !!------------------------------------------------------------------- 407 alfa_charn_3p6_wave = ( pwsh*0.2_wp*(pus/pwps)**2.2_wp ) * grav/(pus*pus)408 !! 409 END FUNCTION alfa_charn_3p6_wave396 charn_coare3p6_wave = ( pwsh*0.2_wp*(pus/pwps)**2.2_wp ) * grav/(pus*pus) 397 !! 398 END FUNCTION charn_coare3p6_wave 410 399 411 400 … … 429 418 REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab 430 419 !!---------------------------------------------------------------------------------- 431 !432 420 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 433 ! 434 zta = pzeta(ji,jj) 435 ! 436 zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable 437 ! 438 zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) & 439 & - 2.*ATAN(zphi_m) + 0.5*rpi 440 ! 441 zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective 442 ! 443 zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 444 & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 445 ! 446 zf = zta*zta 447 zf = zf/(1. + zf) 448 zc = MIN(50._wp, 0.35_wp*zta) 449 zstab = 0.5 + SIGN(0.5_wp, zta) 450 ! 451 psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) 452 & - zstab * ( 1. + 1.*zta & ! (zta > 0) 453 & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! " 454 ! 421 ! 422 zta = pzeta(ji,jj) 423 ! 424 zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable 425 ! 426 zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) & 427 & - 2.*ATAN(zphi_m) + 0.5*rpi 428 ! 429 zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective 430 ! 431 zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 432 & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 433 ! 434 zf = zta*zta 435 zf = zf/(1. + zf) 436 zc = MIN(50._wp, 0.35_wp*zta) 437 zstab = 0.5 + SIGN(0.5_wp, zta) 438 ! 439 psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) 440 & - zstab * ( 1. + 1.*zta & ! (zta > 0) 441 & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! " 455 442 END_2D 456 !457 443 END FUNCTION psi_m_coare 458 444 … … 474 460 !! (https://github.com/brodeau/aerobulk/) 475 461 !!---------------------------------------------------------------- 476 !!477 462 REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare 478 463 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta … … 480 465 INTEGER :: ji, jj ! dummy loop indices 481 466 REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab 482 ! 467 !!---------------------------------------------------------------- 483 468 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 484 ! 485 zta = pzeta(ji,jj) 486 ! 487 zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable) 488 ! 489 zpsi_k = 2.*LOG((1. + zphi_h)/2.) 490 ! 491 zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective 492 ! 493 zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 494 & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 495 ! 496 zf = zta*zta 497 zf = zf/(1. + zf) 498 zc = MIN(50._wp,0.35_wp*zta) 499 zstab = 0.5 + SIGN(0.5_wp, zta) 500 ! 501 psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & 502 & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 & 503 & + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) 504 ! 469 ! 470 zta = pzeta(ji,jj) 471 ! 472 zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable) 473 ! 474 zpsi_k = 2.*LOG((1. + zphi_h)/2.) 475 ! 476 zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective 477 ! 478 zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 479 & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 480 ! 481 zf = zta*zta 482 zf = zf/(1. + zf) 483 zc = MIN(50._wp,0.35_wp*zta) 484 zstab = 0.5 + SIGN(0.5_wp, zta) 485 ! 486 psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & 487 & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 & 488 & + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) 505 489 END_2D 506 !507 490 END FUNCTION psi_h_coare 508 491 -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/SBC/sbcblk_algo_ecmwf.F90
r13460 r13655 5 5 !! * bulk transfer coefficients C_D, C_E and C_H 6 6 !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed 7 !! * the effective bulk wind speed at 10m U _blk7 !! * the effective bulk wind speed at 10m Ubzu 8 8 !! => all these are used in bulk formulas in sbcblk.F90 9 9 !! … … 24 24 !! returns the effective bulk wind speed at 10m 25 25 !!---------------------------------------------------------------------- 26 USE oce ! ocean dynamics and tracers27 26 USE dom_oce ! ocean space and time domain 28 27 USE phycst ! physical constants 29 USE iom ! I/O manager library 30 USE lib_mpp ! distribued memory computing library 31 USE in_out_manager ! I/O manager 32 USE prtctl ! Print control 33 USE sbcwave, ONLY : cdn_wave ! wave module 34 #if defined key_si3 || defined key_cice 35 USE sbc_ice ! Surface boundary condition: ice fields 36 #endif 37 USE lib_fortran ! to use key_nosignedzero 38 39 USE sbc_oce ! Surface boundary condition: ocean fields 40 USE sbcblk_phy ! all thermodynamics functions, rho_air, q_sat, etc... !LB 28 USE lib_mpp, ONLY: ctl_stop ! distribued memory computing library 29 USE in_out_manager, ONLY: nit000 ! I/O manager 30 USE sbc_phy ! all thermodynamics functions, rho_air, q_sat, etc... !LB 41 31 USE sbcblk_skin_ecmwf ! cool-skin/warm layer scheme !LB 42 32 … … 45 35 46 36 PUBLIC :: SBCBLK_ALGO_ECMWF_INIT, TURB_ECMWF 47 !! * Substitutions48 # include "do_loop_substitute.h90"49 37 50 38 !! ECMWF own values for given constants, taken form IFS documentation... 51 REAL(wp), PARAMETER :: charn0 = 0.018! Charnock constant (pretty high value here !!!39 REAL(wp), PARAMETER, PUBLIC :: charn0_ecmwf = 0.018_wp ! Charnock constant (pretty high value here !!! 52 40 ! ! => Usually 0.011 for moderate winds) 53 41 REAL(wp), PARAMETER :: zi0 = 1000. ! scale height of the atmospheric boundary layer...1 … … 57 45 REAL(wp), PARAMETER :: alpha_Q = 0.62 ! 58 46 59 INTEGER , PARAMETER :: nb_itt = 10 ! number of itterations 47 !! * Substitutions 48 # include "do_loop_substitute.h90" 60 49 61 50 !!---------------------------------------------------------------------- … … 94 83 95 84 SUBROUTINE turb_ecmwf( kt, zt, zu, T_s, t_zt, q_s, q_zt, U_zu, l_use_cs, l_use_wl, & 96 & Cd, Ch, Ce, t_zu, q_zu, U _blk,&97 & Cdn, Chn, Cen, &85 & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & 86 & nb_iter, Cdn, Chn, Cen, & ! optional output 98 87 & Qsw, rad_lw, slp, pdT_cs, & ! optionals for cool-skin (and warm-layer) 99 88 & pdT_wl, pHz_wl ) ! optionals for warm-layer only … … 151 140 !! * t_zu : pot. air temperature adjusted at wind height zu [K] 152 141 !! * q_zu : specific humidity of air // [kg/kg] 153 !! * U _blk: bulk wind speed at zu [m/s]142 !! * Ubzu : bulk wind speed at zu [m/s] 154 143 !! 155 144 !! … … 171 160 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] 172 161 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] 173 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: U_blk ! bulk wind speed at zu [m/s] 174 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cdn, Chn, Cen ! neutral transfer coefficients 175 ! 162 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] 163 ! 164 INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations 165 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN 166 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN 167 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN 176 168 REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] 177 169 REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] … … 181 173 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] 182 174 ! 183 INTEGER :: j_itt175 INTEGER :: nbit, jit 184 176 LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U 185 177 ! … … 197 189 !!---------------------------------------------------------------------------------- 198 190 IF( kt == nit000 ) CALL SBCBLK_ALGO_ECMWF_INIT(l_use_cs, l_use_wl) 191 192 nbit = nb_iter0 193 IF( PRESENT(nb_iter) ) nbit = nb_iter 199 194 200 195 l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision … … 227 222 znu_a = visc_air(t_zu) ! Air viscosity (m^2/s) at zt given from temperature in (K) 228 223 229 U _blk= SQRT(U_zu*U_zu + 0.5_wp*0.5_wp) ! initial guess for wind gustiness contribution224 Ubzu = SQRT(U_zu*U_zu + 0.5_wp*0.5_wp) ! initial guess for wind gustiness contribution 230 225 231 226 ztmp0 = LOG( zu*10000._wp) ! optimization: 10000. == 1/z0 (with z0 first guess == 0.0001) 232 227 ztmp1 = LOG(10._wp*10000._wp) ! " " " 233 u_star = 0.035_wp*U _blk*ztmp1/ztmp0 ! (u* = 0.035*Un10)234 235 z0 = charn0 *u_star*u_star/grav + 0.11_wp*znu_a/u_star228 u_star = 0.035_wp*Ubzu*ztmp1/ztmp0 ! (u* = 0.035*Un10) 229 230 z0 = charn0_ecmwf*u_star*u_star/grav + 0.11_wp*znu_a/u_star 236 231 z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) 237 232 … … 239 234 z0t = MIN( MAX(ABS(z0t), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) 240 235 241 Cd = (vkarmn/ztmp0)**2! first guess of Cd242 243 ztmp0 = vkarmn *vkarmn/LOG(zt/z0t)/Cd244 245 ztmp2 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, U _blk) ! Bulk Richardson Number (BRN)236 Cd = MAX( (vkarmn/ztmp0)**2 , Cx_min ) ! first guess of Cd 237 238 ztmp0 = vkarmn2/LOG(zt/z0t)/Cd 239 240 ztmp2 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, Ubzu ) ! Bulk Richardson Number (BRN) 246 241 247 242 !! First estimate of zeta_u, depending on the stability, ie sign of BRN (ztmp2): 248 243 ztmp1 = 0.5 + SIGN( 0.5_wp , ztmp2 ) 249 func_m = ztmp0*ztmp2 ! temporary array !! 250 func_h = (1._wp-ztmp1) * (func_m/(1._wp+ztmp2/(-zu/(zi0*0.004_wp*Beta0**3)))) & ! BRN < 0 ! temporary array !!! func_h == zeta_u 251 & + ztmp1 * (func_m*(1._wp + 27._wp/9._wp*ztmp2/func_m)) ! BRN > 0 252 !#LB: should make sure that the "func_m" of "27./9.*ztmp2/func_m" is "ztmp0*ztmp2" and not "ztmp0==vkarmn*vkarmn/LOG(zt/z0t)/Cd" ! 253 244 func_h = (1._wp - ztmp1) * ztmp0*ztmp2 / (1._wp - ztmp2*zi0*0.004_wp*Beta0**3/zu) & ! BRN < 0 245 & + ztmp1 * ( ztmp0*ztmp2 + 27._wp/9._wp*ztmp2*ztmp2 ) ! BRN > 0 246 254 247 !! First guess M-O stability dependent scaling params.(u*,t*,q*) to estimate z0 and z/L 255 248 ztmp0 = vkarmn/(LOG(zu/z0t) - psi_h_ecmwf(func_h)) 256 249 257 u_star = MAX ( U _blk*vkarmn/(LOG(zu) - LOG(z0) - psi_m_ecmwf(func_h)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on)250 u_star = MAX ( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_ecmwf(func_h)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) 258 251 t_star = dt_zu*ztmp0 259 252 q_star = dq_zu*ztmp0 … … 276 269 277 270 278 !! First guess of inverse of Monin-Obukov length (1/L) :271 !! First guess of inverse of Obukov length (1/L) : 279 272 Linv = One_on_L( t_zu, q_zu, u_star, t_star, q_star ) 280 273 281 !! Functions such as u* = U _blk*vkarmn/func_m274 !! Functions such as u* = Ubzu*vkarmn/func_m 282 275 ztmp0 = zu*Linv 283 276 func_m = LOG(zu) - LOG(z0) - psi_m_ecmwf(ztmp0) + psi_m_ecmwf( z0*Linv) … … 285 278 286 279 !! ITERATION BLOCK 287 DO j _itt = 1, nb_itt280 DO jit = 1, nbit 288 281 289 282 !! Bulk Richardson Number at z=zu (Eq. 3.25) 290 ztmp0 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, U _blk) ! Bulk Richardson Number (BRN)291 292 !! New estimate of the inverse of the Monin-Obukhon length (Linv == zeta/zu) :283 ztmp0 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, Ubzu ) ! Bulk Richardson Number (BRN) 284 285 !! New estimate of the inverse of the Obukhon length (Linv == zeta/zu) : 293 286 Linv = ztmp0*func_m*func_m/func_h / zu ! From Eq. 3.23, Chap.3.2.3, IFS doc - Cy40r1 294 287 !! Note: it is slightly different that the L we would get with the usual … … 299 292 300 293 !! Need to update roughness lengthes: 301 u_star = U _blk*vkarmn/func_m294 u_star = Ubzu*vkarmn/func_m 302 295 ztmp2 = u_star*u_star 303 296 ztmp1 = znu_a/u_star 304 z0 = MIN( ABS( alpha_M*ztmp1 + charn0 *ztmp2/grav ) , 0.001_wp)305 z0t = MIN( ABS( alpha_H*ztmp1 ) , 0.001_wp) ! eq.3.26, Chap.3, p.34, IFS doc - Cy31r1306 z0q = MIN( ABS( alpha_Q*ztmp1 ) , 0.001_wp)297 z0 = MIN( ABS( alpha_M*ztmp1 + charn0_ecmwf*ztmp2/grav ) , 0.001_wp) 298 z0t = MIN( ABS( alpha_H*ztmp1 ) , 0.001_wp) ! eq.3.26, Chap.3, p.34, IFS doc - Cy31r1 299 z0q = MIN( ABS( alpha_Q*ztmp1 ) , 0.001_wp) 307 300 308 301 !! Update wind at zu with convection-related wind gustiness in unstable conditions (Chap. 3.2, IFS doc - Cy40r1, Eq.3.17 and Eq.3.18 + Eq.3.8) 309 302 ztmp2 = Beta0*Beta0*ztmp2*(MAX(-zi0*Linv/vkarmn,0._wp))**(2._wp/3._wp) ! square of wind gustiness contribution (combining Eq. 3.8 and 3.18, hap.3, IFS doc - Cy31r1) 310 303 !! ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before zi0 311 U _blk= MAX(SQRT(U_zu*U_zu + ztmp2), 0.2_wp) ! include gustiness in bulk wind speed312 ! => 0.2 prevents U _blkto be 0 in stable case when U_zu=0.304 Ubzu = MAX(SQRT(U_zu*U_zu + ztmp2), 0.2_wp) ! include gustiness in bulk wind speed 305 ! => 0.2 prevents Ubzu to be 0 in stable case when U_zu=0. 313 306 314 307 … … 346 339 !! Cool-skin contribution 347 340 348 CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, U _blk, slp, rad_lw, &341 CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, & 349 342 & ztmp1, ztmp0, Qlat=ztmp2) ! Qnsol -> ztmp1 / Tau -> ztmp0 350 343 … … 359 352 IF( l_use_wl ) THEN 360 353 !! Warm-layer contribution 361 CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, U _blk, slp, rad_lw, &354 CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, & 362 355 & ztmp1, ztmp2) ! Qnsol -> ztmp1 / Tau -> ztmp2 363 356 CALL WL_ECMWF( Qsw, ztmp1, u_star, zsst ) … … 373 366 ENDIF 374 367 375 END DO !DO j _itt = 1, nb_itt376 377 Cd = vkarmn*vkarmn/(func_m*func_m)378 Ch = vkarmn*vkarmn/(func_m*func_h)379 ztmp2 = log(zu/z0q) - psi_h_ecmwf(zu*Linv) + psi_h_ecmwf(z0q*Linv) ! func_q380 Ce = vkarmn*vkarmn/(func_m*ztmp2)381 382 Cdn = vkarmn*vkarmn / (log(zu/z0 )*log(zu/z0 ))383 Chn = vkarmn*vkarmn / (log(zu/z0t)*log(zu/z0t))384 Cen = vkarmn*vkarmn / (log(zu/z0q)*log(zu/z0q))368 END DO !DO jit = 1, nbit 369 370 Cd = MAX( vkarmn2/(func_m*func_m) , Cx_min ) 371 Ch = MAX( vkarmn2/(func_m*func_h) , Cx_min ) 372 ztmp2 = LOG(zu/z0q) - psi_h_ecmwf(zu*Linv) + psi_h_ecmwf(z0q*Linv) ! func_q 373 Ce = MAX( vkarmn2/(func_m*ztmp2) , Cx_min ) 374 375 IF(PRESENT(Cdn)) Cdn = MAX( vkarmn2 / (LOG(zu/z0 )*LOG(zu/z0 )) , Cx_min ) 376 IF(PRESENT(Chn)) Chn = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) 377 IF(PRESENT(Cen)) Cen = MAX( vkarmn2 / (LOG(zu/z0q)*LOG(zu/z0q)) , Cx_min ) 385 378 386 379 IF( l_use_cs .AND. PRESENT(pdT_cs) ) pdT_cs = dT_cs … … 408 401 ! 409 402 INTEGER :: ji, jj ! dummy loop indices 410 REAL(wp) :: zzeta, zx, ztmp, psi_unst, psi_stab, stab 411 !!---------------------------------------------------------------------------------- 403 REAL(wp) :: zta, zx2, zx, ztmp, zpsi_unst, zpsi_stab, zstab, zc 404 !!---------------------------------------------------------------------------------- 405 zc = 5._wp/0.35_wp 412 406 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 413 ! 414 zzeta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!): 415 ! 416 ! Unstable (Paulson 1970): 417 ! eq.3.20, Chap.3, p.33, IFS doc - Cy31r1 418 zx = SQRT(ABS(1._wp - 16._wp*zzeta)) 419 ztmp = 1._wp + SQRT(zx) 420 ztmp = ztmp*ztmp 421 psi_unst = LOG( 0.125_wp*ztmp*(1._wp + zx) ) & 422 & -2._wp*ATAN( SQRT(zx) ) + 0.5_wp*rpi 423 ! 424 ! Unstable: 425 ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1 426 psi_stab = -2._wp/3._wp*(zzeta - 5._wp/0.35_wp)*EXP(-0.35_wp*zzeta) & 427 & - zzeta - 2._wp/3._wp*5._wp/0.35_wp 428 ! 429 ! Combining: 430 stab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => stab = 1 431 ! 432 psi_m_ecmwf(ji,jj) = (1._wp - stab) * psi_unst & ! (zzeta < 0) Unstable 433 & + stab * psi_stab ! (zzeta > 0) Stable 434 ! 407 ! 408 zta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!): 409 410 ! *** Unstable (Paulson 1970) [eq.3.20, Chap.3, p.33, IFS doc - Cy31r1] : 411 zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 - 16z)^0.5 412 zx = SQRT(zx2) ! (1 - 16z)^0.25 413 ztmp = 1._wp + zx 414 zpsi_unst = LOG( 0.125_wp*ztmp*ztmp*(1._wp + zx2) ) - 2._wp*ATAN( zx ) + 0.5_wp*rpi 415 416 ! *** Stable [eq.3.22, Chap.3, p.33, IFS doc - Cy31r1] : 417 zpsi_stab = -2._wp/3._wp*(zta - zc)*EXP(-0.35_wp*zta) & 418 & - zta - 2._wp/3._wp*zc 419 ! 420 zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 421 ! 422 psi_m_ecmwf(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable 423 & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable 424 ! 435 425 END_2D 436 426 END FUNCTION psi_m_ecmwf … … 452 442 ! 453 443 INTEGER :: ji, jj ! dummy loop indices 454 REAL(wp) :: zzeta, zx, psi_unst, psi_stab, stab 455 !!---------------------------------------------------------------------------------- 444 REAL(wp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab, zc 445 !!---------------------------------------------------------------------------------- 446 zc = 5._wp/0.35_wp 456 447 ! 457 448 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 458 ! 459 zzeta = MIN(pzeta(ji,jj) , 5._wp) ! Very stable conditions (L positif and big!): 460 ! 461 zx = ABS(1._wp - 16._wp*zzeta)**.25 ! this is actually (1/phi_m)**2 !!! 462 ! ! eq.3.19, Chap.3, p.33, IFS doc - Cy31r1 463 ! Unstable (Paulson 1970) : 464 psi_unst = 2._wp*LOG(0.5_wp*(1._wp + zx*zx)) ! eq.3.20, Chap.3, p.33, IFS doc - Cy31r1 465 ! 466 ! Stable: 467 psi_stab = -2._wp/3._wp*(zzeta - 5._wp/0.35_wp)*EXP(-0.35_wp*zzeta) & ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1 468 & - ABS(1._wp + 2._wp/3._wp*zzeta)**1.5_wp - 2._wp/3._wp*5._wp/0.35_wp + 1._wp 469 ! LB: added ABS() to avoid NaN values when unstable, which contaminates the unstable solution... 470 ! 471 stab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => stab = 1 472 ! 473 ! 474 psi_h_ecmwf(ji,jj) = (1._wp - stab) * psi_unst & ! (zzeta < 0) Unstable 475 & + stab * psi_stab ! (zzeta > 0) Stable 476 ! 449 ! 450 zta = MIN(pzeta(ji,jj) , 5._wp) ! Very stable conditions (L positif and big!): 451 ! 452 ! *** Unstable (Paulson 1970) [eq.3.20, Chap.3, p.33, IFS doc - Cy31r1] : 453 zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 -16z)^0.5 454 zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) 455 ! 456 ! *** Stable [eq.3.22, Chap.3, p.33, IFS doc - Cy31r1] : 457 zpsi_stab = -2._wp/3._wp*(zta - zc)*EXP(-0.35_wp*zta) & 458 & - ABS(1._wp + 2._wp/3._wp*zta)**1.5_wp - 2._wp/3._wp*zc + 1._wp 459 ! 460 ! LB: added ABS() to avoid NaN values when unstable, which contaminates the unstable solution... 461 ! 462 zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 463 ! 464 psi_h_ecmwf(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable 465 & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable 466 ! 477 467 END_2D 478 468 END FUNCTION psi_h_ecmwf -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/SBC/sbcblk_algo_ncar.F90
r13460 r13655 5 5 !! * bulk transfer coefficients C_D, C_E and C_H 6 6 !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed 7 !! * the effective bulk wind speed at 10m U _blk7 !! * the effective bulk wind speed at 10m Ubzu 8 8 !! => all these are used in bulk formulas in sbcblk.F90 9 9 !! … … 23 23 !! returns the effective bulk wind speed at 10m 24 24 !!---------------------------------------------------------------------- 25 USE oce ! ocean dynamics and tracers26 25 USE dom_oce ! ocean space and time domain 26 USE sbc_oce, ONLY: ln_cdgw 27 USE sbcwave, ONLY: cdn_wave ! wave module 27 28 USE phycst ! physical constants 28 USE sbc_oce ! Surface boundary condition: ocean fields 29 USE sbcwave, ONLY : cdn_wave ! wave module 30 #if defined key_si3 || defined key_cice 31 USE sbc_ice ! Surface boundary condition: ice fields 32 #endif 33 ! 34 USE iom ! I/O manager library 35 USE lib_mpp ! distribued memory computing library 36 USE in_out_manager ! I/O manager 37 USE prtctl ! Print control 38 USE lib_fortran ! to use key_nosignedzero 39 40 USE sbcblk_phy ! all thermodynamics functions, rho_air, q_sat, etc... !LB 29 USE sbc_phy ! all thermodynamics functions, rho_air, q_sat, etc... !LB 41 30 42 31 IMPLICIT NONE … … 45 34 PUBLIC :: TURB_NCAR ! called by sbcblk.F90 46 35 47 INTEGER , PARAMETER :: nb_itt = 5 ! number of itterations48 36 !! * Substitutions 49 37 # include "do_loop_substitute.h90" … … 52 40 CONTAINS 53 41 54 SUBROUTINE turb_ncar( zt, zu, sst, t_zt, ssq, q_zt, U_zu, &55 & Cd, Ch, Ce, t_zu, q_zu, U_blk,&56 & Cdn, Chn, Cen)42 SUBROUTINE turb_ncar( zt, zu, sst, t_zt, ssq, q_zt, U_zu, & 43 & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & 44 & nb_iter, CdN, ChN, CeN ) 57 45 !!---------------------------------------------------------------------------------- 58 46 !! *** ROUTINE turb_ncar *** … … 61 49 !! fluxes according to Large & Yeager (2004) and Large & Yeager (2008) 62 50 !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu 63 !! Returns the effective bulk wind speed at 10m to be used in the bulk formulas 64 !! 51 !! Returns the effective bulk wind speed at zu to be used in the bulk formulas 65 52 !! 66 53 !! INPUT : … … 82 69 !! * t_zu : pot. air temperature adjusted at wind height zu [K] 83 70 !! * q_zu : specific humidity of air // [kg/kg] 84 !! * U_blk : bulk wind speed at zu [m/s] 85 !! 71 !! * Ubzu : bulk wind speed at zu [m/s] 72 !! 73 !! OPTIONAL OUTPUT: 74 !! ---------------- 75 !! * CdN : neutral-stability drag coefficient 76 !! * ChN : neutral-stability sensible heat coefficient 77 !! * CeN : neutral-stability evaporation coefficient 86 78 !! 87 79 !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) … … 99 91 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] 100 92 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] 101 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: U_blk ! bulk wind speed at zu [m/s] 102 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cdn, Chn, Cen ! neutral transfer coefficients 103 ! 104 INTEGER :: j_itt 93 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] 94 ! 95 INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations 96 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN 97 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN 98 REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN 99 ! 100 INTEGER :: nbit, jit ! iterations... 105 101 LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U 106 102 ! 107 REAL(wp), DIMENSION(jpi,jpj) :: Cx_n10! 10m neutral latent/sensible coefficient108 REAL(wp), DIMENSION(jpi,jpj) :: sqrt_Cd_n10 ! root square of Cd_n10103 REAL(wp), DIMENSION(jpi,jpj) :: zCdN, zCeN, zChN ! 10m neutral latent/sensible coefficient 104 REAL(wp), DIMENSION(jpi,jpj) :: zsqrt_Cd, zsqrt_CdN ! root square of Cd and Cd_neutral 109 105 REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu 110 REAL(wp), DIMENSION(jpi,jpj) :: zpsi_h_u111 106 REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 112 REAL(wp), DIMENSION(jpi,jpj) :: stab ! stability test integer 113 !!---------------------------------------------------------------------------------- 107 !!---------------------------------------------------------------------------------- 108 nbit = nb_iter0 109 IF( PRESENT(nb_iter) ) nbit = nb_iter 110 114 111 l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision 115 112 116 U _blk= MAX( 0.5_wp , U_zu ) ! relative wind speed at zu (normally 10m), we don't want to fall under 0.5 m/s113 Ubzu = MAX( 0.5_wp , U_zu ) ! relative wind speed at zu (normally 10m), we don't want to fall under 0.5 m/s 117 114 118 115 !! First guess of stability: 119 116 ztmp0 = virt_temp(t_zt, q_zt) - virt_temp(sst, ssq) ! air-sea difference of virtual pot. temp. at zt 120 stab = 0.5_wp + sign(0.5_wp,ztmp0) ! stab= 1 if dTv > 0 => STABLE, 0 if unstable117 ztmp1 = 0.5_wp + SIGN(0.5_wp,ztmp0) ! ztmp1 = 1 if dTv > 0 => STABLE, 0 if unstable 121 118 122 119 !! Neutral coefficients at 10m: 123 120 IF( ln_cdgw ) THEN ! wave drag case 124 121 cdn_wave(:,:) = cdn_wave(:,:) + rsmall * ( 1._wp - tmask(:,:,1) ) 125 z tmp0(:,:) = cdn_wave(:,:)122 zCdN (:,:) = cdn_wave(:,:) 126 123 ELSE 127 z tmp0 = cd_neutral_10m( U_blk)124 zCdN = cd_n10_ncar( Ubzu ) 128 125 ENDIF 129 126 130 sqrt_Cd_n10 = SQRT( ztmp0)127 zsqrt_CdN = SQRT( zCdN ) 131 128 132 129 !! Initializing transf. coeff. with their first guess neutral equivalents : 133 Cd = z tmp0134 Ce = 1.e-3_wp*( 34.6_wp * sqrt_Cd_n10)135 Ch = 1.e-3_wp*sqrt_Cd_n10*(18._wp*stab + 32.7_wp*(1._wp - stab))136 stab = sqrt_Cd_n10 ! Temporaty array !!! stab == SQRT(Cd)137 130 Cd = zCdN 131 Ce = ce_n10_ncar( zsqrt_CdN ) 132 Ch = ch_n10_ncar( zsqrt_CdN , ztmp1 ) ! ztmp1 is stability (1/0) 133 zsqrt_Cd = zsqrt_CdN 134 138 135 IF( ln_cdgw ) THEN 139 Cen= Ce140 Chn= Ch136 zCeN = Ce 137 zChN = Ch 141 138 ENDIF 142 139 143 !! First guess of temperature and humidity at height zu:140 !! Initializing values at z_u with z_t values: 144 141 t_zu = MAX( t_zt , 180._wp ) ! who knows what's given on masked-continental regions... 145 142 q_zu = MAX( q_zt , 1.e-6_wp ) ! " 146 143 144 147 145 !! ITERATION BLOCK 148 DO j _itt = 1, nb_itt146 DO jit = 1, nbit 149 147 ! 150 148 ztmp1 = t_zu - sst ! Updating air/sea differences 151 149 ztmp2 = q_zu - ssq 152 150 153 ! Updating turbulent scales : (L&Y 2004 eq. (7))154 ztmp0 = stab*U_blk ! u* (stab == SQRT(Cd))155 ztmp1 = Ch/ stab*ztmp1 ! theta* (stab == SQRT(Cd))156 ztmp2 = Ce/ stab*ztmp2 ! q* (stab == SQRT(Cd))157 158 ! Estimate the inverse of Monin-Obukov length (1/L) at height zu:151 ! Updating turbulent scales : (L&Y 2004 Eq. (7)) 152 ztmp0 = zsqrt_Cd*Ubzu ! u* 153 ztmp1 = Ch/zsqrt_Cd*ztmp1 ! theta* 154 ztmp2 = Ce/zsqrt_Cd*ztmp2 ! q* 155 156 ! Estimate the inverse of Obukov length (1/L) at height zu: 159 157 ztmp0 = One_on_L( t_zu, q_zu, ztmp0, ztmp1, ztmp2 ) 160 158 161 159 !! Stability parameters : 162 160 zeta_u = zu*ztmp0 163 zeta_u = sign( min(abs(zeta_u),10._wp), zeta_u ) 164 zpsi_h_u = psi_h( zeta_u ) 165 166 !! Shifting temperature and humidity at zu (L&Y 2004 eq. (9b-9c)) 161 zeta_u = sign( min(abs(zeta_u),10._wp), zeta_u ) 162 163 !! Shifting temperature and humidity at zu (L&Y 2004 Eq. (9b-9c)) 167 164 IF( .NOT. l_zt_equal_zu ) THEN 168 !! Array 'stab' is free for the moment so using it to store 'zeta_t'169 stab = zt*ztmp0170 stab = SIGN( MIN(ABS(stab),10._wp), stab ) ! Temporaty array stab == zeta_t !!!171 stab = LOG(zt/zu) + zpsi_h_u - psi_h(stab) ! stab just used as temp array again!172 t_zu = t_zt - ztmp1/vkarmn*stab ! ztmp1 is still theta* L&Y 2004 eq.(9b)173 q_zu = q_zt - ztmp2/vkarmn* stab ! ztmp2 is still q* L&Y 2004 eq.(9c)174 q_zu = max(0._wp, q_zu)175 END IF176 177 ! Update neutral wind speed at 10m and neutral Cd at 10m (L&Y 2004 eq. 9a)...165 ztmp0 = zt*ztmp0 ! zeta_t ! 166 ztmp0 = SIGN( MIN(ABS(ztmp0),10._wp), ztmp0 ) ! Temporaty array ztmp0 == zeta_t !!! 167 ztmp0 = LOG(zt/zu) + psi_h_ncar(zeta_u) - psi_h_ncar(ztmp0) ! ztmp0 just used as temp array again! 168 t_zu = t_zt - ztmp1/vkarmn*ztmp0 ! ztmp1 is still theta* L&Y 2004 Eq. (9b) 169 !! 170 q_zu = q_zt - ztmp2/vkarmn*ztmp0 ! ztmp2 is still q* L&Y 2004 Eq. (9c) 171 q_zu = MAX(0._wp, q_zu) 172 END IF 173 174 ! Update neutral wind speed at 10m and neutral Cd at 10m (L&Y 2004 Eq. 9a)... 178 175 ! In very rare low-wind conditions, the old way of estimating the 179 176 ! neutral wind speed at 10m leads to a negative value that causes the code 180 177 ! to crash. To prevent this a threshold of 0.25m/s is imposed. 181 ztmp2 = psi_m (zeta_u)178 ztmp2 = psi_m_ncar(zeta_u) 182 179 IF( ln_cdgw ) THEN ! surface wave case 183 stab = vkarmn / ( vkarmn / sqrt_Cd_n10 - ztmp2 ) ! (stab == SQRT(Cd))184 Cd = stab * stab185 ztmp0 = (LOG(zu/10._wp) - zpsi_h_u) / vkarmn / sqrt_Cd_n10186 ztmp2 = stab / sqrt_Cd_n10 ! (stab == SQRT(Cd))187 ztmp1 = 1._wp + Chn * ztmp0188 Ch = Chn* ztmp2 / ztmp1 ! L&Y 2004 eq. (10b)189 ztmp1 = 1._wp + Cen* ztmp0190 Ce = Cen* ztmp2 / ztmp1 ! L&Y 2004 eq. (10c)180 zsqrt_Cd = vkarmn / ( vkarmn / zsqrt_CdN - ztmp2 ) 181 Cd = zsqrt_Cd * zsqrt_Cd 182 ztmp0 = (LOG(zu/10._wp) - psi_h_ncar(zeta_u)) / vkarmn / zsqrt_CdN 183 ztmp2 = zsqrt_Cd / zsqrt_CdN 184 ztmp1 = 1._wp + zChN * ztmp0 185 Ch = zChN * ztmp2 / ztmp1 ! L&Y 2004 eq. (10b) 186 ztmp1 = 1._wp + zCeN * ztmp0 187 Ce = zCeN * ztmp2 / ztmp1 ! L&Y 2004 eq. (10c) 191 188 192 189 ELSE 193 ! Update neutral wind speed at 10m and neutral Cd at 10m (L&Y 2004 eq. 9a)... 194 ! In very rare low-wind conditions, the old way of estimating the 195 ! neutral wind speed at 10m leads to a negative value that causes the code 196 ! to crash. To prevent this a threshold of 0.25m/s is imposed. 197 ztmp0 = MAX( 0.25_wp , U_blk/(1._wp + sqrt_Cd_n10/vkarmn*(LOG(zu/10._wp) - ztmp2)) ) ! U_n10 (ztmp2 == psi_m(zeta_u)) 198 ztmp0 = cd_neutral_10m(ztmp0) ! Cd_n10 199 Cdn(:,:) = ztmp0 200 sqrt_Cd_n10 = sqrt(ztmp0) 201 202 stab = 0.5_wp + sign(0.5_wp,zeta_u) ! update stability 203 Cx_n10 = 1.e-3_wp*sqrt_Cd_n10*(18._wp*stab + 32.7_wp*(1._wp - stab)) ! L&Y 2004 eq. (6c-6d) (Cx_n10 == Ch_n10) 204 Chn(:,:) = Cx_n10 190 ztmp0 = MAX( 0.25_wp , UN10_from_CD(zu, Ubzu, Cd, ppsi=ztmp2) ) ! U_n10 (ztmp2 == psi_m_ncar(zeta_u)) 191 192 zCdN = cd_n10_ncar(ztmp0) 193 zsqrt_CdN = sqrt(zCdN) 205 194 206 195 !! Update of transfer coefficients: 207 ztmp1 = 1._wp + sqrt_Cd_n10/vkarmn*(LOG(zu/10._wp) - ztmp2) ! L&Y 2004 eq. (10a) (ztmp2 == psi_m(zeta_u)) 208 Cd = ztmp0 / ( ztmp1*ztmp1 ) 209 stab = SQRT( Cd ) ! Temporary array !!! (stab == SQRT(Cd)) 210 211 ztmp0 = (LOG(zu/10._wp) - zpsi_h_u) / vkarmn / sqrt_Cd_n10 212 ztmp2 = stab / sqrt_Cd_n10 ! (stab == SQRT(Cd)) 213 ztmp1 = 1._wp + Cx_n10*ztmp0 ! (Cx_n10 == Ch_n10) 214 Ch = Cx_n10*ztmp2 / ztmp1 ! L&Y 2004 eq. (10b) 215 216 Cx_n10 = 1.e-3_wp * (34.6_wp * sqrt_Cd_n10) ! L&Y 2004 eq. (6b) ! Cx_n10 == Ce_n10 217 Cen(:,:) = Cx_n10 218 ztmp1 = 1._wp + Cx_n10*ztmp0 219 Ce = Cx_n10*ztmp2 / ztmp1 ! L&Y 2004 eq. (10c) 196 197 !! C_D 198 ztmp1 = 1._wp + zsqrt_CdN/vkarmn*(LOG(zu/10._wp) - ztmp2) ! L&Y 2004 Eq. (10a) (ztmp2 == psi_m(zeta_u)) 199 Cd = MAX( zCdN / ( ztmp1*ztmp1 ), Cx_min ) 200 201 !! C_H and C_E 202 zsqrt_Cd = SQRT( Cd ) 203 ztmp0 = ( LOG(zu/10._wp) - psi_h_ncar(zeta_u) ) / vkarmn / zsqrt_CdN 204 ztmp2 = zsqrt_Cd / zsqrt_CdN 205 206 ztmp1 = 0.5_wp + SIGN(0.5_wp,zeta_u) ! update stability 207 zChN = 1.e-3_wp * zsqrt_CdN*(18._wp*ztmp1 + 32.7_wp*(1._wp - ztmp1)) ! L&Y 2004 eq. (6c-6d) 208 zCeN = 1.e-3_wp * (34.6_wp * zsqrt_CdN) ! L&Y 2004 eq. (6b) 209 210 Ch = MAX( zChN*ztmp2 / ( 1._wp + zChN*ztmp0 ) , Cx_min ) ! L&Y 2004 eq. (10b) 211 Ce = MAX( zCeN*ztmp2 / ( 1._wp + zCeN*ztmp0 ) , Cx_min ) ! L&Y 2004 eq. (10c) 212 220 213 ENDIF 221 222 END DO !DO j_itt = 1, nb_itt 214 215 END DO !DO jit = 1, nbit 216 217 IF(PRESENT(CdN)) CdN(:,:) = zCdN(:,:) 218 IF(PRESENT(CeN)) CeN(:,:) = zCeN(:,:) 219 IF(PRESENT(ChN)) ChN(:,:) = zChN(:,:) 223 220 224 221 END SUBROUTINE turb_ncar 225 222 226 223 227 FUNCTION cd_n eutral_10m( pw10 )228 !!---------------------------------------------------------------------------------- 224 FUNCTION cd_n10_ncar( pw10 ) 225 !!---------------------------------------------------------------------------------- 229 226 !! Estimate of the neutral drag coefficient at 10m as a function 230 227 !! of neutral wind speed at 10m 231 228 !! 232 !! Origin: Large & Yeager 2008 eq.(11a) and eq.(11b)229 !! Origin: Large & Yeager 2008, Eq. (11) 233 230 !! 234 231 !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) 235 232 !!---------------------------------------------------------------------------------- 236 233 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pw10 ! scalar wind speed at 10m (m/s) 237 REAL(wp), DIMENSION(jpi,jpj) :: cd_n eutral_10m234 REAL(wp), DIMENSION(jpi,jpj) :: cd_n10_ncar 238 235 ! 239 236 INTEGER :: ji, jj ! dummy loop indices … … 242 239 ! 243 240 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 244 !245 zw = pw10(ji,jj)246 zw6 = zw*zw*zw247 zw6 = zw6*zw6248 !249 ! When wind speed > 33 m/s => Cyclone conditions => special treatment250 zgt33 = 0.5_wp + SIGN( 0.5_wp, (zw - 33._wp) ) ! If pw10 < 33. => 0, else => 1251 !252 cd_neutral_10m(ji,jj) = 1.e-3_wp * ( &253 & (1._wp - zgt33)*( 2.7_wp/zw + 0.142_wp + zw/13.09_wp - 3.14807E-10_wp*zw6) & ! wind < 33 m/s254 & + zgt33 * 2.34_wp ) ! wind >= 33 m/s255 !256 cd_neutral_10m(ji,jj) = MAX(cd_neutral_10m(ji,jj), 1.E-6_wp)257 !241 ! 242 zw = pw10(ji,jj) 243 zw6 = zw*zw*zw 244 zw6 = zw6*zw6 245 ! 246 ! When wind speed > 33 m/s => Cyclone conditions => special treatment 247 zgt33 = 0.5_wp + SIGN( 0.5_wp, (zw - 33._wp) ) ! If pw10 < 33. => 0, else => 1 248 ! 249 cd_n10_ncar(ji,jj) = 1.e-3_wp * ( & 250 & (1._wp - zgt33)*( 2.7_wp/zw + 0.142_wp + zw/13.09_wp - 3.14807E-10_wp*zw6) & ! wind < 33 m/s 251 & + zgt33 * 2.34_wp ) ! wind >= 33 m/s 252 ! 253 cd_n10_ncar(ji,jj) = MAX( cd_n10_ncar(ji,jj), Cx_min ) 254 ! 258 255 END_2D 259 256 ! 260 END FUNCTION cd_neutral_10m 261 262 263 FUNCTION psi_m( pzeta ) 257 END FUNCTION cd_n10_ncar 258 259 260 FUNCTION ch_n10_ncar( psqrtcdn10 , pstab ) 261 !!---------------------------------------------------------------------------------- 262 !! Estimate of the neutral heat transfer coefficient at 10m !! 263 !! Origin: Large & Yeager 2008, Eq. (9) and (12) 264 265 !!---------------------------------------------------------------------------------- 266 REAL(wp), DIMENSION(jpi,jpj) :: ch_n10_ncar 267 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) 268 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pstab ! stable ABL => 1 / unstable ABL => 0 269 !!---------------------------------------------------------------------------------- 270 IF( ANY(pstab < -0.00001) .OR. ANY(pstab > 1.00001) ) THEN 271 PRINT *, 'ERROR: ch_n10_ncar@mod_blk_ncar.f90: pstab =' 272 PRINT *, pstab 273 STOP 274 END IF 275 ! 276 ch_n10_ncar = MAX( 1.e-3_wp * psqrtcdn10*( 18._wp*pstab + 32.7_wp*(1._wp - pstab) ) , Cx_min ) ! Eq. (9) & (12) Large & Yeager, 2008 277 ! 278 END FUNCTION ch_n10_ncar 279 280 FUNCTION ce_n10_ncar( psqrtcdn10 ) 281 !!---------------------------------------------------------------------------------- 282 !! Estimate of the neutral heat transfer coefficient at 10m !! 283 !! Origin: Large & Yeager 2008, Eq. (9) and (13) 284 !!---------------------------------------------------------------------------------- 285 REAL(wp), DIMENSION(jpi,jpj) :: ce_n10_ncar 286 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) 287 !!---------------------------------------------------------------------------------- 288 ce_n10_ncar = MAX( 1.e-3_wp * ( 34.6_wp * psqrtcdn10 ) , Cx_min ) 289 ! 290 END FUNCTION ce_n10_ncar 291 292 293 FUNCTION psi_m_ncar( pzeta ) 264 294 !!---------------------------------------------------------------------------------- 265 295 !! Universal profile stability function for momentum 266 !! !! Psis, L&Y 2004 eq. (8c), (8d), (8e)296 !! !! Psis, L&Y 2004, Eq. (8c), (8d), (8e) 267 297 !! 268 298 !! pzeta : stability paramenter, z/L where z is altitude measurement … … 271 301 !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) 272 302 !!---------------------------------------------------------------------------------- 273 REAL(wp), DIMENSION(jpi,jpj) :: psi_m 303 REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ncar 274 304 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta 275 305 ! 276 306 INTEGER :: ji, jj ! dummy loop indices 277 REAL(wp) :: z x2, zx,zstab ! local scalars307 REAL(wp) :: zta, zx2, zx, zpsi_unst, zpsi_stab, zstab ! local scalars 278 308 !!---------------------------------------------------------------------------------- 279 309 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 280 zx2 = SQRT( ABS( 1._wp - 16._wp*pzeta(ji,jj) ) ) 281 zx2 = MAX( zx2 , 1._wp ) 282 zx = SQRT( zx2 ) 283 zstab = 0.5_wp + SIGN( 0.5_wp , pzeta(ji,jj) ) 284 ! 285 psi_m(ji,jj) = zstab * (-5._wp*pzeta(ji,jj)) & ! Stable 286 & + (1._wp - zstab) * (2._wp*LOG((1._wp + zx)*0.5_wp) & ! Unstable 287 & + LOG((1._wp + zx2)*0.5_wp) - 2._wp*ATAN(zx) + rpi*0.5_wp) ! " 288 ! 310 zta = pzeta(ji,jj) 311 ! 312 zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 - 16z)^0.5 313 zx2 = MAX( zx2 , 1._wp ) 314 zx = SQRT(zx2) ! (1 - 16z)^0.25 315 zpsi_unst = 2._wp*LOG( (1._wp + zx )*0.5_wp ) & 316 & + LOG( (1._wp + zx2)*0.5_wp ) & 317 & - 2._wp*ATAN(zx) + rpi*0.5_wp 318 ! 319 zpsi_stab = -5._wp*zta 320 ! 321 zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 322 ! 323 psi_m_ncar(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable 324 & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable 325 ! 326 ! 289 327 END_2D 290 END FUNCTION psi_m 291 292 293 FUNCTION psi_h ( pzeta )328 END FUNCTION psi_m_ncar 329 330 331 FUNCTION psi_h_ncar( pzeta ) 294 332 !!---------------------------------------------------------------------------------- 295 333 !! Universal profile stability function for temperature and humidity 296 !! !! Psis, L&Y 2004 eq. (8c), (8d), (8e)334 !! !! Psis, L&Y 2004, Eq. (8c), (8d), (8e) 297 335 !! 298 336 !! pzeta : stability paramenter, z/L where z is altitude measurement … … 301 339 !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) 302 340 !!---------------------------------------------------------------------------------- 303 REAL(wp), DIMENSION(jpi,jpj) :: psi_h 341 REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ncar 304 342 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta 305 343 ! 306 344 INTEGER :: ji, jj ! dummy loop indices 307 REAL(wp) :: z x2, zstab ! local scalars345 REAL(wp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars 308 346 !!---------------------------------------------------------------------------------- 309 347 ! 310 348 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 311 zx2 = SQRT( ABS( 1._wp - 16._wp*pzeta(ji,jj) ) ) 312 zx2 = MAX( zx2 , 1._wp ) 313 zstab = 0.5_wp + SIGN( 0.5_wp , pzeta(ji,jj) ) 314 ! 315 psi_h(ji,jj) = zstab * (-5._wp*pzeta(ji,jj)) & ! Stable 316 & + (1._wp - zstab) * (2._wp*LOG( (1._wp + zx2)*0.5_wp )) ! Unstable 317 ! 349 ! 350 zta = pzeta(ji,jj) 351 ! 352 zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 -16z)^0.5 353 zx2 = MAX( zx2 , 1._wp ) 354 zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) 355 ! 356 zpsi_stab = -5._wp*zta 357 ! 358 zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 359 ! 360 psi_h_ncar(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable 361 & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable 362 ! 318 363 END_2D 319 END FUNCTION psi_h 364 END FUNCTION psi_h_ncar 320 365 321 366 !!====================================================================== -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/SBC/sbcblk_skin_coare.F90
r13460 r13655 20 20 USE sbc_oce ! Surface boundary condition: ocean fields 21 21 22 USE sbc blk_phy! misc. functions for marine ABL physics (rho_air, q_sat, bulk_formula, etc)22 USE sbc_phy ! misc. functions for marine ABL physics (rho_air, q_sat, bulk_formula, etc) 23 23 24 24 USE sbcdcy !#LB: to know hour of dawn and dusk: rdawn_dcy and rdusk_dcy (needed in WL_COARE) -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/SBC/sbcblk_skin_ecmwf.F90
r13460 r13655 35 35 USE sbc_oce ! Surface boundary condition: ocean fields 36 36 37 USE sbc blk_phy! misc. functions for marine ABL physics (rho_air, q_sat, bulk_formula, etc)37 USE sbc_phy ! misc. functions for marine ABL physics (rho_air, q_sat, bulk_formula, etc) 38 38 39 39 USE lib_mpp ! distribued memory computing library -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/SBC/sbccpl.F90
r13497 r13655 32 32 #endif 33 33 USE cpl_oasis3 ! OASIS3 coupling 34 USE geo2ocean ! 34 USE geo2ocean ! 35 35 USE oce , ONLY : ts, uu, vv, ssh, fraqsr_1lev 36 USE ocealb ! 37 USE eosbn2 ! 36 USE ocealb ! 37 USE eosbn2 ! 38 38 USE sbcrnf , ONLY : l_rnfcpl 39 39 #if defined key_cice … … 49 49 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 50 50 51 #if defined key_oasis3 52 USE mod_oasis, ONLY : OASIS_Sent, OASIS_ToRest, OASIS_SentOut, OASIS_ToRestOut 53 #endif 51 #if defined key_oasis3 52 USE mod_oasis, ONLY : OASIS_Sent, OASIS_ToRest, OASIS_SentOut, OASIS_ToRestOut 53 #endif 54 55 USE sbc_phy, ONLY : pp_cldf 54 56 55 57 IMPLICIT NONE … … 64 66 65 67 INTEGER, PARAMETER :: jpr_otx1 = 1 ! 3 atmosphere-ocean stress components on grid 1 66 INTEGER, PARAMETER :: jpr_oty1 = 2 ! 67 INTEGER, PARAMETER :: jpr_otz1 = 3 ! 68 INTEGER, PARAMETER :: jpr_oty1 = 2 ! 69 INTEGER, PARAMETER :: jpr_otz1 = 3 ! 68 70 INTEGER, PARAMETER :: jpr_otx2 = 4 ! 3 atmosphere-ocean stress components on grid 2 69 INTEGER, PARAMETER :: jpr_oty2 = 5 ! 70 INTEGER, PARAMETER :: jpr_otz2 = 6 ! 71 INTEGER, PARAMETER :: jpr_oty2 = 5 ! 72 INTEGER, PARAMETER :: jpr_otz2 = 6 ! 71 73 INTEGER, PARAMETER :: jpr_itx1 = 7 ! 3 atmosphere-ice stress components on grid 1 72 INTEGER, PARAMETER :: jpr_ity1 = 8 ! 73 INTEGER, PARAMETER :: jpr_itz1 = 9 ! 74 INTEGER, PARAMETER :: jpr_ity1 = 8 ! 75 INTEGER, PARAMETER :: jpr_itz1 = 9 ! 74 76 INTEGER, PARAMETER :: jpr_itx2 = 10 ! 3 atmosphere-ice stress components on grid 2 75 INTEGER, PARAMETER :: jpr_ity2 = 11 ! 76 INTEGER, PARAMETER :: jpr_itz2 = 12 ! 77 INTEGER, PARAMETER :: jpr_ity2 = 11 ! 78 INTEGER, PARAMETER :: jpr_itz2 = 12 ! 77 79 INTEGER, PARAMETER :: jpr_qsroce = 13 ! Qsr above the ocean 78 80 INTEGER, PARAMETER :: jpr_qsrice = 14 ! Qsr above the ice 79 INTEGER, PARAMETER :: jpr_qsrmix = 15 81 INTEGER, PARAMETER :: jpr_qsrmix = 15 80 82 INTEGER, PARAMETER :: jpr_qnsoce = 16 ! Qns above the ocean 81 83 INTEGER, PARAMETER :: jpr_qnsice = 17 ! Qns above the ice … … 102 104 INTEGER, PARAMETER :: jpr_ocy1 = 38 ! 103 105 INTEGER, PARAMETER :: jpr_ssh = 39 ! sea surface height 104 INTEGER, PARAMETER :: jpr_fice = 40 ! ice fraction 105 INTEGER, PARAMETER :: jpr_e3t1st = 41 ! first T level thickness 106 INTEGER, PARAMETER :: jpr_fice = 40 ! ice fraction 107 INTEGER, PARAMETER :: jpr_e3t1st = 41 ! first T level thickness 106 108 INTEGER, PARAMETER :: jpr_fraqsr = 42 ! fraction of solar net radiation absorbed in the first ocean level 107 INTEGER, PARAMETER :: jpr_mslp = 43 ! mean sea level pressure 108 INTEGER, PARAMETER :: jpr_hsig = 44 ! Hsig 109 INTEGER, PARAMETER :: jpr_phioc = 45 ! Wave=>ocean energy flux 110 INTEGER, PARAMETER :: jpr_sdrftx = 46 ! Stokes drift on grid 1 111 INTEGER, PARAMETER :: jpr_sdrfty = 47 ! Stokes drift on grid 2 109 INTEGER, PARAMETER :: jpr_mslp = 43 ! mean sea level pressure 110 INTEGER, PARAMETER :: jpr_hsig = 44 ! Hsig 111 INTEGER, PARAMETER :: jpr_phioc = 45 ! Wave=>ocean energy flux 112 INTEGER, PARAMETER :: jpr_sdrftx = 46 ! Stokes drift on grid 1 113 INTEGER, PARAMETER :: jpr_sdrfty = 47 ! Stokes drift on grid 2 112 114 INTEGER, PARAMETER :: jpr_wper = 48 ! Mean wave period 113 115 INTEGER, PARAMETER :: jpr_wnum = 49 ! Mean wavenumber … … 121 123 INTEGER, PARAMETER :: jpr_ts_ice = 57 ! Sea ice surface temp 122 124 123 INTEGER, PARAMETER :: jprcv = 57 ! total number of fields received 125 INTEGER, PARAMETER :: jprcv = 57 ! total number of fields received 124 126 125 127 INTEGER, PARAMETER :: jps_fice = 1 ! ice fraction sent to the atmosphere … … 145 147 INTEGER, PARAMETER :: jps_sflx = 21 ! salt flux 146 148 INTEGER, PARAMETER :: jps_otx1 = 22 ! 2 atmosphere-ocean stress components on grid 1 147 INTEGER, PARAMETER :: jps_oty1 = 23 ! 149 INTEGER, PARAMETER :: jps_oty1 = 23 ! 148 150 INTEGER, PARAMETER :: jps_rnf = 24 ! runoffs 149 151 INTEGER, PARAMETER :: jps_taum = 25 ! wind stress module … … 151 153 INTEGER, PARAMETER :: jps_e3t1st = 27 ! first level depth (vvl) 152 154 INTEGER, PARAMETER :: jps_fraqsr = 28 ! fraction of solar net radiation absorbed in the first ocean level 153 INTEGER, PARAMETER :: jps_ficet = 29 ! total ice fraction 154 INTEGER, PARAMETER :: jps_ocxw = 30 ! currents on grid 1 155 INTEGER, PARAMETER :: jps_ficet = 29 ! total ice fraction 156 INTEGER, PARAMETER :: jps_ocxw = 30 ! currents on grid 1 155 157 INTEGER, PARAMETER :: jps_ocyw = 31 ! currents on grid 2 156 INTEGER, PARAMETER :: jps_wlev = 32 ! water level 158 INTEGER, PARAMETER :: jps_wlev = 32 ! water level 157 159 INTEGER, PARAMETER :: jps_fice1 = 33 ! first-order ice concentration (for semi-implicit coupling of atmos-ice fluxes) 158 160 INTEGER, PARAMETER :: jps_a_p = 34 ! meltpond area fraction … … 162 164 INTEGER, PARAMETER :: jps_ttilyr = 38 ! sea ice top layer temp 163 165 164 INTEGER, PARAMETER :: jpsnd = 38 ! total number of fields sent 165 166 #if ! defined key_oasis3 167 ! Dummy variables to enable compilation when oasis3 is not being used 168 INTEGER :: OASIS_Sent = -1 169 INTEGER :: OASIS_SentOut = -1 170 INTEGER :: OASIS_ToRest = -1 171 INTEGER :: OASIS_ToRestOut = -1 172 #endif 166 INTEGER, PARAMETER :: jpsnd = 38 ! total number of fields sent 167 168 #if ! defined key_oasis3 169 ! Dummy variables to enable compilation when oasis3 is not being used 170 INTEGER :: OASIS_Sent = -1 171 INTEGER :: OASIS_SentOut = -1 172 INTEGER :: OASIS_ToRest = -1 173 INTEGER :: OASIS_ToRestOut = -1 174 #endif 173 175 174 176 ! !!** namelist namsbc_cpl ** 175 TYPE :: FLD_C ! 177 TYPE :: FLD_C ! 176 178 CHARACTER(len = 32) :: cldes ! desciption of the coupling strategy 177 179 CHARACTER(len = 32) :: clcat ! multiple ice categories strategy … … 180 182 CHARACTER(len = 32) :: clvgrd ! grids on which is located the vector fields 181 183 END TYPE FLD_C 182 ! ! Send to the atmosphere 184 ! ! Send to the atmosphere 183 185 TYPE(FLD_C) :: sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2, & 184 186 & sn_snd_thick1, sn_snd_cond, sn_snd_mpnd , sn_snd_sstfrz, sn_snd_ttilyr … … 187 189 & sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf, sn_rcv_ts_ice 188 190 TYPE(FLD_C) :: sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2, sn_rcv_mslp, sn_rcv_icb, sn_rcv_isf 189 ! Send to waves 190 TYPE(FLD_C) :: sn_snd_ifrac, sn_snd_crtw, sn_snd_wlev 191 ! Received from waves 191 ! Send to waves 192 TYPE(FLD_C) :: sn_snd_ifrac, sn_snd_crtw, sn_snd_wlev 193 ! Received from waves 192 194 TYPE(FLD_C) :: sn_rcv_hsig, sn_rcv_phioc, sn_rcv_sdrfx, sn_rcv_sdrfy, sn_rcv_wper, sn_rcv_wnum, sn_rcv_tauwoc, & 193 195 sn_rcv_wdrag, sn_rcv_wfreq … … 196 198 LOGICAL :: ln_usecplmask ! use a coupling mask file to merge data received from several models 197 199 ! -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel) 198 LOGICAL :: ln_scale_ice_flux ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration) 199 200 TYPE :: DYNARR 201 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3 200 LOGICAL :: ln_scale_ice_flux ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration) 201 202 TYPE :: DYNARR 203 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3 202 204 END TYPE DYNARR 203 205 … … 209 211 #endif 210 212 211 REAL(wp) :: rpref = 101000._wp ! reference atmospheric pressure[N/m2] 212 REAL(wp) :: r1_grau ! = 1.e0 / (grav * rho0) 213 REAL(wp) :: rpref = 101000._wp ! reference atmospheric pressure[N/m2] 214 REAL(wp) :: r1_grau ! = 1.e0 / (grav * rho0) 213 215 214 216 INTEGER , ALLOCATABLE, SAVE, DIMENSION(:) :: nrcvinfo ! OASIS info argument … … 223 225 !!---------------------------------------------------------------------- 224 226 CONTAINS 225 227 226 228 INTEGER FUNCTION sbc_cpl_alloc() 227 229 !!---------------------------------------------------------------------- … … 233 235 ! 234 236 ALLOCATE( alb_oce_mix(jpi,jpj), nrcvinfo(jprcv), STAT=ierr(1) ) 235 237 236 238 #if ! defined key_si3 && ! defined key_cice 237 239 ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) ) ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init) … … 251 253 252 254 253 SUBROUTINE sbc_cpl_init( k_ice ) 255 SUBROUTINE sbc_cpl_init( k_ice ) 254 256 !!---------------------------------------------------------------------- 255 257 !! *** ROUTINE sbc_cpl_init *** … … 258 260 !! the atmospheric component 259 261 !! 260 !! ** Method : * Read namsbc_cpl namelist 262 !! ** Method : * Read namsbc_cpl namelist 261 263 !! * define the receive interface 262 264 !! * define the send interface … … 270 272 !! 271 273 NAMELIST/namsbc_cpl/ nn_cplmodel , ln_usecplmask, nn_cats_cpl , ln_scale_ice_flux, & 272 & sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2 , & 273 & sn_snd_ttilyr, sn_snd_cond , sn_snd_mpnd , sn_snd_sstfrz, sn_snd_thick1, & 274 & sn_snd_ifrac , sn_snd_crtw , sn_snd_wlev , sn_rcv_hsig , sn_rcv_phioc , & 275 & sn_rcv_w10m , sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr , & 274 & sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2 , & 275 & sn_snd_ttilyr, sn_snd_cond , sn_snd_mpnd , sn_snd_sstfrz, sn_snd_thick1, & 276 & sn_snd_ifrac , sn_snd_crtw , sn_snd_wlev , sn_rcv_hsig , sn_rcv_phioc , & 277 & sn_rcv_w10m , sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr , & 276 278 & sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum , sn_rcv_tauwoc, & 277 279 & sn_rcv_wdrag , sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , & … … 319 321 WRITE(numout,*)' sea ice heat fluxes = ', TRIM(sn_rcv_iceflx%cldes), ' (', TRIM(sn_rcv_iceflx%clcat), ')' 320 322 WRITE(numout,*)' atm co2 = ', TRIM(sn_rcv_co2%cldes ), ' (', TRIM(sn_rcv_co2%clcat ), ')' 321 WRITE(numout,*)' significant wave heigth = ', TRIM(sn_rcv_hsig%cldes ), ' (', TRIM(sn_rcv_hsig%clcat ), ')' 322 WRITE(numout,*)' wave to oce energy flux = ', TRIM(sn_rcv_phioc%cldes ), ' (', TRIM(sn_rcv_phioc%clcat ), ')' 323 WRITE(numout,*)' Surface Stokes drift grid u = ', TRIM(sn_rcv_sdrfx%cldes ), ' (', TRIM(sn_rcv_sdrfx%clcat ), ')' 324 WRITE(numout,*)' Surface Stokes drift grid v = ', TRIM(sn_rcv_sdrfy%cldes ), ' (', TRIM(sn_rcv_sdrfy%clcat ), ')' 325 WRITE(numout,*)' Mean wave period = ', TRIM(sn_rcv_wper%cldes ), ' (', TRIM(sn_rcv_wper%clcat ), ')' 326 WRITE(numout,*)' Mean wave number = ', TRIM(sn_rcv_wnum%cldes ), ' (', TRIM(sn_rcv_wnum%clcat ), ')' 323 WRITE(numout,*)' significant wave heigth = ', TRIM(sn_rcv_hsig%cldes ), ' (', TRIM(sn_rcv_hsig%clcat ), ')' 324 WRITE(numout,*)' wave to oce energy flux = ', TRIM(sn_rcv_phioc%cldes ), ' (', TRIM(sn_rcv_phioc%clcat ), ')' 325 WRITE(numout,*)' Surface Stokes drift grid u = ', TRIM(sn_rcv_sdrfx%cldes ), ' (', TRIM(sn_rcv_sdrfx%clcat ), ')' 326 WRITE(numout,*)' Surface Stokes drift grid v = ', TRIM(sn_rcv_sdrfy%cldes ), ' (', TRIM(sn_rcv_sdrfy%clcat ), ')' 327 WRITE(numout,*)' Mean wave period = ', TRIM(sn_rcv_wper%cldes ), ' (', TRIM(sn_rcv_wper%clcat ), ')' 328 WRITE(numout,*)' Mean wave number = ', TRIM(sn_rcv_wnum%cldes ), ' (', TRIM(sn_rcv_wnum%clcat ), ')' 327 329 WRITE(numout,*)' Wave peak frequency = ', TRIM(sn_rcv_wfreq%cldes ), ' (', TRIM(sn_rcv_wfreq%clcat ), ')' 328 WRITE(numout,*)' Stress frac adsorbed by waves = ', TRIM(sn_rcv_tauwoc%cldes), ' (', TRIM(sn_rcv_tauwoc%clcat ), ')' 330 WRITE(numout,*)' Stress frac adsorbed by waves = ', TRIM(sn_rcv_tauwoc%cldes), ' (', TRIM(sn_rcv_tauwoc%clcat ), ')' 329 331 WRITE(numout,*)' Stress components by waves = ', TRIM(sn_rcv_tauw%cldes ), ' (', TRIM(sn_rcv_tauw%clcat ), ')' 330 WRITE(numout,*)' Neutral surf drag coefficient = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')' 331 WRITE(numout,*)' Sea ice surface skin temperature= ', TRIM(sn_rcv_ts_ice%cldes), ' (', TRIM(sn_rcv_ts_ice%clcat), ')' 332 WRITE(numout,*)' Neutral surf drag coefficient = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')' 333 WRITE(numout,*)' Sea ice surface skin temperature= ', TRIM(sn_rcv_ts_ice%cldes), ' (', TRIM(sn_rcv_ts_ice%clcat), ')' 332 334 WRITE(numout,*)' sent fields (multiple ice categories)' 333 335 WRITE(numout,*)' surface temperature = ', TRIM(sn_snd_temp%cldes ), ' (', TRIM(sn_snd_temp%clcat ), ')' … … 335 337 WRITE(numout,*)' albedo = ', TRIM(sn_snd_alb%cldes ), ' (', TRIM(sn_snd_alb%clcat ), ')' 336 338 WRITE(numout,*)' ice/snow thickness = ', TRIM(sn_snd_thick%cldes ), ' (', TRIM(sn_snd_thick%clcat ), ')' 337 WRITE(numout,*)' total ice fraction = ', TRIM(sn_snd_ifrac%cldes ), ' (', TRIM(sn_snd_ifrac%clcat ), ')' 339 WRITE(numout,*)' total ice fraction = ', TRIM(sn_snd_ifrac%cldes ), ' (', TRIM(sn_snd_ifrac%clcat ), ')' 338 340 WRITE(numout,*)' surface current = ', TRIM(sn_snd_crt%cldes ), ' (', TRIM(sn_snd_crt%clcat ), ')' 339 WRITE(numout,*)' - referential = ', sn_snd_crt%clvref 341 WRITE(numout,*)' - referential = ', sn_snd_crt%clvref 340 342 WRITE(numout,*)' - orientation = ', sn_snd_crt%clvor 341 343 WRITE(numout,*)' - mesh = ', sn_snd_crt%clvgrd … … 344 346 WRITE(numout,*)' meltponds fraction and depth = ', TRIM(sn_snd_mpnd%cldes ), ' (', TRIM(sn_snd_mpnd%clcat ), ')' 345 347 WRITE(numout,*)' sea surface freezing temp = ', TRIM(sn_snd_sstfrz%cldes), ' (', TRIM(sn_snd_sstfrz%clcat), ')' 346 WRITE(numout,*)' water level = ', TRIM(sn_snd_wlev%cldes ), ' (', TRIM(sn_snd_wlev%clcat ), ')' 347 WRITE(numout,*)' mean sea level pressure = ', TRIM(sn_rcv_mslp%cldes ), ' (', TRIM(sn_rcv_mslp%clcat ), ')' 348 WRITE(numout,*)' surface current to waves = ', TRIM(sn_snd_crtw%cldes ), ' (', TRIM(sn_snd_crtw%clcat ), ')' 349 WRITE(numout,*)' - referential = ', sn_snd_crtw%clvref 350 WRITE(numout,*)' - orientation = ', sn_snd_crtw%clvor 351 WRITE(numout,*)' - mesh = ', sn_snd_crtw%clvgrd 348 WRITE(numout,*)' water level = ', TRIM(sn_snd_wlev%cldes ), ' (', TRIM(sn_snd_wlev%clcat ), ')' 349 WRITE(numout,*)' mean sea level pressure = ', TRIM(sn_rcv_mslp%cldes ), ' (', TRIM(sn_rcv_mslp%clcat ), ')' 350 WRITE(numout,*)' surface current to waves = ', TRIM(sn_snd_crtw%cldes ), ' (', TRIM(sn_snd_crtw%clcat ), ')' 351 WRITE(numout,*)' - referential = ', sn_snd_crtw%clvref 352 WRITE(numout,*)' - orientation = ', sn_snd_crtw%clvor 353 WRITE(numout,*)' - mesh = ', sn_snd_crtw%clvgrd 352 354 ENDIF 353 355 354 356 ! ! allocate sbccpl arrays 355 357 IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) 356 358 357 359 ! ================================ ! 358 360 ! Define the receive interface ! 359 361 ! ================================ ! 360 nrcvinfo(:) = OASIS_idle ! needed by nrcvinfo(jpr_otx1) if we do not receive ocean stress 362 nrcvinfo(:) = OASIS_idle ! needed by nrcvinfo(jpr_otx1) if we do not receive ocean stress 361 363 362 364 ! for each field: define the OASIS name (srcv(:)%clname) … … 368 370 369 371 ! ! ------------------------- ! 370 ! ! ice and ocean wind stress ! 371 ! ! ------------------------- ! 372 ! ! Name 372 ! ! ice and ocean wind stress ! 373 ! ! ------------------------- ! 374 ! ! Name 373 375 srcv(jpr_otx1)%clname = 'O_OTaux1' ! 1st ocean component on grid ONE (T or U) 374 srcv(jpr_oty1)%clname = 'O_OTauy1' ! 2nd - - - - 375 srcv(jpr_otz1)%clname = 'O_OTauz1' ! 3rd - - - - 376 srcv(jpr_oty1)%clname = 'O_OTauy1' ! 2nd - - - - 377 srcv(jpr_otz1)%clname = 'O_OTauz1' ! 3rd - - - - 376 378 srcv(jpr_otx2)%clname = 'O_OTaux2' ! 1st ocean component on grid TWO (V) 377 srcv(jpr_oty2)%clname = 'O_OTauy2' ! 2nd - - - - 378 srcv(jpr_otz2)%clname = 'O_OTauz2' ! 3rd - - - - 379 srcv(jpr_oty2)%clname = 'O_OTauy2' ! 2nd - - - - 380 srcv(jpr_otz2)%clname = 'O_OTauz2' ! 3rd - - - - 379 381 ! 380 382 srcv(jpr_itx1)%clname = 'O_ITaux1' ! 1st ice component on grid ONE (T, F, I or U) 381 srcv(jpr_ity1)%clname = 'O_ITauy1' ! 2nd - - - - 382 srcv(jpr_itz1)%clname = 'O_ITauz1' ! 3rd - - - - 383 srcv(jpr_ity1)%clname = 'O_ITauy1' ! 2nd - - - - 384 srcv(jpr_itz1)%clname = 'O_ITauz1' ! 3rd - - - - 383 385 srcv(jpr_itx2)%clname = 'O_ITaux2' ! 1st ice component on grid TWO (V) 384 srcv(jpr_ity2)%clname = 'O_ITauy2' ! 2nd - - - - 385 srcv(jpr_itz2)%clname = 'O_ITauz2' ! 3rd - - - - 386 ! 386 srcv(jpr_ity2)%clname = 'O_ITauy2' ! 2nd - - - - 387 srcv(jpr_itz2)%clname = 'O_ITauz2' ! 3rd - - - - 388 ! 387 389 ! Vectors: change of sign at north fold ONLY if on the local grid 388 390 IF( TRIM( sn_rcv_tau%cldes ) == 'oce only' .OR. TRIM( sn_rcv_tau%cldes ) == 'oce and ice' & … … 390 392 ! 391 393 IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) srcv(jpr_otx1:jpr_itz2)%nsgn = -1. 392 394 393 395 ! ! Set grid and action 394 396 SELECT CASE( TRIM( sn_rcv_tau%clvgrd ) ) ! 'T', 'U,V', 'U,V,I', 'U,V,F', 'T,I', 'T,F', or 'T,U,V' 395 CASE( 'T' ) 397 CASE( 'T' ) 396 398 srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point 397 srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 398 srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 399 CASE( 'U,V' ) 399 srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 400 srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 401 CASE( 'U,V' ) 400 402 srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point 401 403 srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point … … 421 423 srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2 422 424 srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only 423 CASE( 'T,I' ) 425 CASE( 'T,I' ) 424 426 srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point 425 427 srcv(jpr_itx1:jpr_itz1)%clgrid = 'I' ! ice components given at I-point 426 srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 427 srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 428 CASE( 'T,F' ) 428 srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 429 srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 430 CASE( 'T,F' ) 429 431 srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point 430 432 srcv(jpr_itx1:jpr_itz1)%clgrid = 'F' ! ice components given at F-point 431 srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 432 srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 433 srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 434 srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 433 435 CASE( 'T,U,V' ) 434 436 srcv(jpr_otx1:jpr_otz1)%clgrid = 'T' ! oce components given at T-point … … 437 439 srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 only 438 440 srcv(jpr_itx1:jpr_itz2)%laction = .TRUE. ! receive ice components on grid 1 & 2 439 CASE default 441 CASE default 440 442 CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_tau%clvgrd' ) 441 443 END SELECT 442 444 ! 443 445 IF( TRIM( sn_rcv_tau%clvref ) == 'spherical' ) & ! spherical: 3rd component not received 444 & srcv( (/jpr_otz1, jpr_otz2, jpr_itz1, jpr_itz2/) )%laction = .FALSE. 446 & srcv( (/jpr_otz1, jpr_otz2, jpr_itz1, jpr_itz2/) )%laction = .FALSE. 445 447 ! 446 448 IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) THEN ! already on local grid -> no need of the second grid 447 srcv(jpr_otx2:jpr_otz2)%laction = .FALSE. 448 srcv(jpr_itx2:jpr_itz2)%laction = .FALSE. 449 srcv(jpr_otx2:jpr_otz2)%laction = .FALSE. 450 srcv(jpr_itx2:jpr_itz2)%laction = .FALSE. 449 451 srcv(jpr_oty1)%clgrid = srcv(jpr_oty2)%clgrid ! not needed but cleaner... 450 452 srcv(jpr_ity1)%clgrid = srcv(jpr_ity2)%clgrid ! not needed but cleaner... … … 462 464 ! ! ------------------------- ! 463 465 ! we suppose that atmosphere modele do not make the difference between precipiration (liquide or solid) 464 ! over ice of free ocean within the same atmospheric cell.cd 466 ! over ice of free ocean within the same atmospheric cell.cd 465 467 srcv(jpr_rain)%clname = 'OTotRain' ! Rain = liquid precipitation 466 468 srcv(jpr_snow)%clname = 'OTotSnow' ! Snow = solid precipitation 467 469 srcv(jpr_tevp)%clname = 'OTotEvap' ! total evaporation (over oce + ice sublimation) 468 470 srcv(jpr_ievp)%clname = 'OIceEvap' ! evaporation over ice = sublimation 469 srcv(jpr_sbpr)%clname = 'OSubMPre' ! sublimation - liquid precipitation - solid precipitation 471 srcv(jpr_sbpr)%clname = 'OSubMPre' ! sublimation - liquid precipitation - solid precipitation 470 472 srcv(jpr_semp)%clname = 'OISubMSn' ! ice solid water budget = sublimation - solid precipitation 471 473 srcv(jpr_oemp)%clname = 'OOEvaMPr' ! ocean water budget = ocean Evap - ocean precip 472 474 SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 473 475 CASE( 'none' ) ! nothing to do 474 CASE( 'oce only' ) ; srcv(jpr_oemp)%laction = .TRUE. 476 CASE( 'oce only' ) ; srcv(jpr_oemp)%laction = .TRUE. 475 477 CASE( 'conservative' ) 476 478 srcv( (/jpr_rain, jpr_snow, jpr_ievp, jpr_tevp/) )%laction = .TRUE. … … 481 483 ! 482 484 ! ! ------------------------- ! 483 ! ! Runoffs & Calving ! 485 ! ! Runoffs & Calving ! 484 486 ! ! ------------------------- ! 485 487 srcv(jpr_rnf )%clname = 'O_Runoff' … … 514 516 CASE( 'conservative' ) ; srcv( (/jpr_qnsice, jpr_qnsmix/) )%laction = .TRUE. 515 517 CASE( 'oce and ice' ) ; srcv( (/jpr_qnsice, jpr_qnsoce/) )%laction = .TRUE. 516 CASE( 'mixed oce-ice' ) ; srcv( jpr_qnsmix )%laction = .TRUE. 518 CASE( 'mixed oce-ice' ) ; srcv( jpr_qnsmix )%laction = .TRUE. 517 519 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qns%cldes' ) 518 520 END SELECT … … 531 533 CASE( 'conservative' ) ; srcv( (/jpr_qsrice, jpr_qsrmix/) )%laction = .TRUE. 532 534 CASE( 'oce and ice' ) ; srcv( (/jpr_qsrice, jpr_qsroce/) )%laction = .TRUE. 533 CASE( 'mixed oce-ice' ) ; srcv( jpr_qsrmix )%laction = .TRUE. 535 CASE( 'mixed oce-ice' ) ; srcv( jpr_qsrmix )%laction = .TRUE. 534 536 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qsr%cldes' ) 535 537 END SELECT … … 540 542 ! ! non solar sensitivity ! d(Qns)/d(T) 541 543 ! ! ------------------------- ! 542 srcv(jpr_dqnsdt)%clname = 'O_dQnsdT' 544 srcv(jpr_dqnsdt)%clname = 'O_dQnsdT' 543 545 IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'coupled' ) srcv(jpr_dqnsdt)%laction = .TRUE. 544 546 ! … … 548 550 ! 549 551 ! ! ------------------------- ! 550 ! ! 10m wind module ! 551 ! ! ------------------------- ! 552 srcv(jpr_w10m)%clname = 'O_Wind10' ; IF( TRIM(sn_rcv_w10m%cldes ) == 'coupled' ) srcv(jpr_w10m)%laction = .TRUE. 553 ! 554 ! ! ------------------------- ! 555 ! ! wind stress module ! 552 ! ! 10m wind module ! 553 ! ! ------------------------- ! 554 srcv(jpr_w10m)%clname = 'O_Wind10' ; IF( TRIM(sn_rcv_w10m%cldes ) == 'coupled' ) srcv(jpr_w10m)%laction = .TRUE. 555 ! 556 ! ! ------------------------- ! 557 ! ! wind stress module ! 556 558 ! ! ------------------------- ! 557 559 srcv(jpr_taum)%clname = 'O_TauMod' ; IF( TRIM(sn_rcv_taumod%cldes) == 'coupled' ) srcv(jpr_taum)%laction = .TRUE. … … 560 562 ! ! Atmospheric CO2 ! 561 563 ! ! ------------------------- ! 562 srcv(jpr_co2 )%clname = 'O_AtmCO2' 564 srcv(jpr_co2 )%clname = 'O_AtmCO2' 563 565 IF( TRIM(sn_rcv_co2%cldes ) == 'coupled' ) THEN 564 566 srcv(jpr_co2 )%laction = .TRUE. … … 569 571 ENDIF 570 572 ! 571 ! ! ------------------------- ! 572 ! ! Mean Sea Level Pressure ! 573 ! ! ------------------------- ! 574 srcv(jpr_mslp)%clname = 'O_MSLP' ; IF( TRIM(sn_rcv_mslp%cldes ) == 'coupled' ) srcv(jpr_mslp)%laction = .TRUE. 575 ! 576 ! ! ------------------------- ! 577 ! ! ice topmelt and botmelt ! 573 ! ! ------------------------- ! 574 ! ! Mean Sea Level Pressure ! 575 ! ! ------------------------- ! 576 srcv(jpr_mslp)%clname = 'O_MSLP' ; IF( TRIM(sn_rcv_mslp%cldes ) == 'coupled' ) srcv(jpr_mslp)%laction = .TRUE. 577 ! 578 ! ! ------------------------- ! 579 ! ! ice topmelt and botmelt ! 578 580 ! ! ------------------------- ! 579 581 srcv(jpr_topm )%clname = 'OTopMlt' … … 588 590 ENDIF 589 591 ! ! ------------------------- ! 590 ! ! ice skin temperature ! 592 ! ! ice skin temperature ! 591 593 ! ! ------------------------- ! 592 594 srcv(jpr_ts_ice)%clname = 'OTsfIce' ! needed by Met Office … … 596 598 597 599 #if defined key_si3 598 IF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN 600 IF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN 599 601 IF( .NOT.srcv(jpr_ts_ice)%laction ) & 600 & CALL ctl_stop( 'sbc_cpl_init: srcv(jpr_ts_ice)%laction should be set to true when ln_cndflx=T' ) 602 & CALL ctl_stop( 'sbc_cpl_init: srcv(jpr_ts_ice)%laction should be set to true when ln_cndflx=T' ) 601 603 ENDIF 602 604 #endif 603 605 ! ! ------------------------- ! 604 ! ! Wave breaking ! 605 ! ! ------------------------- ! 606 ! ! Wave breaking ! 607 ! ! ------------------------- ! 606 608 srcv(jpr_hsig)%clname = 'O_Hsigwa' ! significant wave height 607 609 IF( TRIM(sn_rcv_hsig%cldes ) == 'coupled' ) THEN … … 629 631 cpl_wper = .TRUE. 630 632 ENDIF 631 srcv(jpr_wfreq)%clname = 'O_WFreq' ! wave peak frequency 633 srcv(jpr_wfreq)%clname = 'O_WFreq' ! wave peak frequency 632 634 IF( TRIM(sn_rcv_wfreq%cldes ) == 'coupled' ) THEN 633 635 srcv(jpr_wfreq)%laction = .TRUE. … … 661 663 ! 662 664 ! ! ------------------------------- ! 663 ! ! OPA-SAS coupling - rcv by opa ! 665 ! ! OPA-SAS coupling - rcv by opa ! 664 666 ! ! ------------------------------- ! 665 667 srcv(jpr_sflx)%clname = 'O_SFLX' … … 697 699 ENDIF 698 700 ! ! -------------------------------- ! 699 ! ! OPA-SAS coupling - rcv by sas ! 701 ! ! OPA-SAS coupling - rcv by sas ! 700 702 ! ! -------------------------------- ! 701 703 srcv(jpr_toce )%clname = 'I_SSTSST' … … 704 706 srcv(jpr_ocy1 )%clname = 'I_OCury1' 705 707 srcv(jpr_ssh )%clname = 'I_SSHght' 706 srcv(jpr_e3t1st)%clname = 'I_E3T1st' 707 srcv(jpr_fraqsr)%clname = 'I_FraQsr' 708 srcv(jpr_e3t1st)%clname = 'I_E3T1st' 709 srcv(jpr_fraqsr)%clname = 'I_FraQsr' 708 710 ! 709 711 IF( nn_components == jp_iam_sas ) THEN … … 735 737 ENDIF 736 738 WRITE(numout,*)' sea surface temperature (Celsius) ' 737 WRITE(numout,*)' sea surface salinity ' 738 WRITE(numout,*)' surface currents ' 739 WRITE(numout,*)' sea surface height ' 740 WRITE(numout,*)' thickness of first ocean T level ' 739 WRITE(numout,*)' sea surface salinity ' 740 WRITE(numout,*)' surface currents ' 741 WRITE(numout,*)' sea surface height ' 742 WRITE(numout,*)' thickness of first ocean T level ' 741 743 WRITE(numout,*)' fraction of solar net radiation absorbed in the first ocean level' 742 744 WRITE(numout,*) 743 745 ENDIF 744 746 ENDIF 745 747 746 748 ! =================================================== ! 747 749 ! Allocate all parts of frcv used for received fields ! … … 769 771 ! define send or not from the namelist parameters (ssnd(:)%laction) 770 772 ! define the north fold type of lbc (ssnd(:)%nsgn) 771 773 772 774 ! default definitions of nsnd 773 775 ssnd(:)%laction = .FALSE. ; ssnd(:)%clgrid = 'T' ; ssnd(:)%nsgn = 1. ; ssnd(:)%nct = 1 774 776 775 777 ! ! ------------------------- ! 776 778 ! ! Surface temperature ! … … 789 791 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_temp%cldes' ) 790 792 END SELECT 791 793 792 794 ! ! ------------------------- ! 793 795 ! ! Albedo ! 794 796 ! ! ------------------------- ! 795 ssnd(jps_albice)%clname = 'O_AlbIce' 797 ssnd(jps_albice)%clname = 'O_AlbIce' 796 798 ssnd(jps_albmix)%clname = 'O_AlbMix' 797 799 SELECT CASE( TRIM( sn_snd_alb%cldes ) ) … … 804 806 ! Need to calculate oceanic albedo if 805 807 ! 1. sending mixed oce-ice albedo or 806 ! 2. receiving mixed oce-ice solar radiation 808 ! 2. receiving mixed oce-ice solar radiation 807 809 IF( TRIM ( sn_snd_alb%cldes ) == 'mixed oce-ice' .OR. TRIM ( sn_rcv_qsr%cldes ) == 'mixed oce-ice' ) THEN 808 810 CALL oce_alb( zaos, zacs ) … … 811 813 ENDIF 812 814 ! ! ------------------------- ! 813 ! ! Ice fraction & Thickness ! 815 ! ! Ice fraction & Thickness ! 814 816 ! ! ------------------------- ! 815 817 ssnd(jps_fice)%clname = 'OIceFrc' 816 ssnd(jps_ficet)%clname = 'OIceFrcT' 818 ssnd(jps_ficet)%clname = 'OIceFrcT' 817 819 ssnd(jps_hice)%clname = 'OIceTck' 818 820 ssnd(jps_a_p)%clname = 'OPndFrc' … … 827 829 IF( TRIM( sn_snd_thick1%clcat ) == 'yes' ) ssnd(jps_fice1)%nct = nn_cats_cpl 828 830 ENDIF 829 830 IF(TRIM( sn_snd_ifrac%cldes ) == 'coupled') ssnd(jps_ficet)%laction = .TRUE. 831 832 IF(TRIM( sn_snd_ifrac%cldes ) == 'coupled') ssnd(jps_ficet)%laction = .TRUE. 831 833 832 834 SELECT CASE ( TRIM( sn_snd_thick%cldes ) ) 833 835 CASE( 'none' ) ! nothing to do 834 CASE( 'ice and snow' ) 836 CASE( 'ice and snow' ) 835 837 ssnd(jps_hice:jps_hsnw)%laction = .TRUE. 836 838 IF( TRIM( sn_snd_thick%clcat ) == 'yes' ) THEN 837 839 ssnd(jps_hice:jps_hsnw)%nct = nn_cats_cpl 838 840 ENDIF 839 CASE ( 'weighted ice and snow' ) 841 CASE ( 'weighted ice and snow' ) 840 842 ssnd(jps_hice:jps_hsnw)%laction = .TRUE. 841 843 IF( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_hice:jps_hsnw)%nct = nn_cats_cpl … … 847 849 a_i_last_couple(:,:,:) = 0._wp 848 850 #endif 849 ! ! ------------------------- ! 850 ! ! Ice Meltponds ! 851 ! ! ------------------------- ! 851 ! ! ------------------------- ! 852 ! ! Ice Meltponds ! 853 ! ! ------------------------- ! 852 854 ! Needed by Met Office 853 ssnd(jps_a_p)%clname = 'OPndFrc' 854 ssnd(jps_ht_p)%clname = 'OPndTck' 855 SELECT CASE ( TRIM( sn_snd_mpnd%cldes ) ) 856 CASE ( 'none' ) 857 ssnd(jps_a_p)%laction = .FALSE. 858 ssnd(jps_ht_p)%laction = .FALSE. 859 CASE ( 'ice only' ) 860 ssnd(jps_a_p)%laction = .TRUE. 861 ssnd(jps_ht_p)%laction = .TRUE. 862 IF( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN 863 ssnd(jps_a_p)%nct = nn_cats_cpl 864 ssnd(jps_ht_p)%nct = nn_cats_cpl 865 ELSE 866 IF( nn_cats_cpl > 1 ) THEN 867 CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_mpnd%cldes if not exchanging category fields' ) 868 ENDIF 869 ENDIF 870 CASE ( 'weighted ice' ) 871 ssnd(jps_a_p)%laction = .TRUE. 872 ssnd(jps_ht_p)%laction = .TRUE. 873 IF( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN 874 ssnd(jps_a_p)%nct = nn_cats_cpl 875 ssnd(jps_ht_p)%nct = nn_cats_cpl 876 ENDIF 877 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_mpnd%cldes; '//sn_snd_mpnd%cldes ) 878 END SELECT 879 855 ssnd(jps_a_p)%clname = 'OPndFrc' 856 ssnd(jps_ht_p)%clname = 'OPndTck' 857 SELECT CASE ( TRIM( sn_snd_mpnd%cldes ) ) 858 CASE ( 'none' ) 859 ssnd(jps_a_p)%laction = .FALSE. 860 ssnd(jps_ht_p)%laction = .FALSE. 861 CASE ( 'ice only' ) 862 ssnd(jps_a_p)%laction = .TRUE. 863 ssnd(jps_ht_p)%laction = .TRUE. 864 IF( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN 865 ssnd(jps_a_p)%nct = nn_cats_cpl 866 ssnd(jps_ht_p)%nct = nn_cats_cpl 867 ELSE 868 IF( nn_cats_cpl > 1 ) THEN 869 CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_mpnd%cldes if not exchanging category fields' ) 870 ENDIF 871 ENDIF 872 CASE ( 'weighted ice' ) 873 ssnd(jps_a_p)%laction = .TRUE. 874 ssnd(jps_ht_p)%laction = .TRUE. 875 IF( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN 876 ssnd(jps_a_p)%nct = nn_cats_cpl 877 ssnd(jps_ht_p)%nct = nn_cats_cpl 878 ENDIF 879 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_mpnd%cldes; '//sn_snd_mpnd%cldes ) 880 END SELECT 881 880 882 ! ! ------------------------- ! 881 883 ! ! Surface current ! … … 885 887 ssnd(jps_ocy1)%clname = 'O_OCury1' ; ssnd(jps_ivy1)%clname = 'O_IVely1' 886 888 ssnd(jps_ocz1)%clname = 'O_OCurz1' ; ssnd(jps_ivz1)%clname = 'O_IVelz1' 887 ssnd(jps_ocxw)%clname = 'O_OCurxw' 888 ssnd(jps_ocyw)%clname = 'O_OCuryw' 889 ssnd(jps_ocxw)%clname = 'O_OCurxw' 890 ssnd(jps_ocyw)%clname = 'O_OCuryw' 889 891 ! 890 892 ssnd(jps_ocx1:jps_ivz1)%nsgn = -1. ! vectors: change of the sign at the north fold … … 892 894 IF( sn_snd_crt%clvgrd == 'U,V' ) THEN 893 895 ssnd(jps_ocx1)%clgrid = 'U' ; ssnd(jps_ocy1)%clgrid = 'V' 894 ELSE IF( sn_snd_crt%clvgrd /= 'T' ) THEN 896 ELSE IF( sn_snd_crt%clvgrd /= 'T' ) THEN 895 897 CALL ctl_stop( 'sn_snd_crt%clvgrd must be equal to T' ) 896 898 ENDIF 897 899 ssnd(jps_ocx1:jps_ivz1)%laction = .TRUE. ! default: all are send 898 IF( TRIM( sn_snd_crt%clvref ) == 'spherical' ) ssnd( (/jps_ocz1, jps_ivz1/) )%laction = .FALSE. 900 IF( TRIM( sn_snd_crt%clvref ) == 'spherical' ) ssnd( (/jps_ocz1, jps_ivz1/) )%laction = .FALSE. 899 901 IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) ssnd(jps_ocx1:jps_ivz1)%nsgn = 1. 900 902 SELECT CASE( TRIM( sn_snd_crt%cldes ) ) … … 906 908 END SELECT 907 909 908 ssnd(jps_ocxw:jps_ocyw)%nsgn = -1. ! vectors: change of the sign at the north fold 909 910 IF( sn_snd_crtw%clvgrd == 'U,V' ) THEN 911 ssnd(jps_ocxw)%clgrid = 'U' ; ssnd(jps_ocyw)%clgrid = 'V' 912 ELSE IF( sn_snd_crtw%clvgrd /= 'T' ) THEN 913 CALL ctl_stop( 'sn_snd_crtw%clvgrd must be equal to T' ) 914 ENDIF 915 IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) ssnd(jps_ocxw:jps_ocyw)%nsgn = 1. 916 SELECT CASE( TRIM( sn_snd_crtw%cldes ) ) 917 CASE( 'none' ) ; ssnd(jps_ocxw:jps_ocyw)%laction = .FALSE. 918 CASE( 'oce only' ) ; ssnd(jps_ocxw:jps_ocyw)%laction = .TRUE. 919 CASE( 'weighted oce and ice' ) ! nothing to do 920 CASE( 'mixed oce-ice' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE. 921 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_crtw%cldes' ) 922 END SELECT 910 ssnd(jps_ocxw:jps_ocyw)%nsgn = -1. ! vectors: change of the sign at the north fold 911 912 IF( sn_snd_crtw%clvgrd == 'U,V' ) THEN 913 ssnd(jps_ocxw)%clgrid = 'U' ; ssnd(jps_ocyw)%clgrid = 'V' 914 ELSE IF( sn_snd_crtw%clvgrd /= 'T' ) THEN 915 CALL ctl_stop( 'sn_snd_crtw%clvgrd must be equal to T' ) 916 ENDIF 917 IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) ssnd(jps_ocxw:jps_ocyw)%nsgn = 1. 918 SELECT CASE( TRIM( sn_snd_crtw%cldes ) ) 919 CASE( 'none' ) ; ssnd(jps_ocxw:jps_ocyw)%laction = .FALSE. 920 CASE( 'oce only' ) ; ssnd(jps_ocxw:jps_ocyw)%laction = .TRUE. 921 CASE( 'weighted oce and ice' ) ! nothing to do 922 CASE( 'mixed oce-ice' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE. 923 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_crtw%cldes' ) 924 END SELECT 923 925 924 926 ! ! ------------------------- ! … … 926 928 ! ! ------------------------- ! 927 929 ssnd(jps_co2)%clname = 'O_CO2FLX' ; IF( TRIM(sn_snd_co2%cldes) == 'coupled' ) ssnd(jps_co2 )%laction = .TRUE. 928 ! 929 ! ! ------------------------- ! 930 ! ! Sea surface freezing temp ! 931 ! ! ------------------------- ! 930 ! 931 ! ! ------------------------- ! 932 ! ! Sea surface freezing temp ! 933 ! ! ------------------------- ! 932 934 ! needed by Met Office 933 ssnd(jps_sstfrz)%clname = 'O_SSTFrz' ; IF( TRIM(sn_snd_sstfrz%cldes) == 'coupled' ) ssnd(jps_sstfrz)%laction = .TRUE. 934 ! 935 ! ! ------------------------- ! 936 ! ! Ice conductivity ! 937 ! ! ------------------------- ! 935 ssnd(jps_sstfrz)%clname = 'O_SSTFrz' ; IF( TRIM(sn_snd_sstfrz%cldes) == 'coupled' ) ssnd(jps_sstfrz)%laction = .TRUE. 936 ! 937 ! ! ------------------------- ! 938 ! ! Ice conductivity ! 939 ! ! ------------------------- ! 938 940 ! needed by Met Office 939 ! Note that ultimately we will move to passing an ocean effective conductivity as well so there 940 ! will be some changes to the parts of the code which currently relate only to ice conductivity 941 ssnd(jps_ttilyr )%clname = 'O_TtiLyr' 942 SELECT CASE ( TRIM( sn_snd_ttilyr%cldes ) ) 943 CASE ( 'none' ) 944 ssnd(jps_ttilyr)%laction = .FALSE. 945 CASE ( 'ice only' ) 946 ssnd(jps_ttilyr)%laction = .TRUE. 947 IF( TRIM( sn_snd_ttilyr%clcat ) == 'yes' ) THEN 948 ssnd(jps_ttilyr)%nct = nn_cats_cpl 949 ELSE 950 IF( nn_cats_cpl > 1 ) THEN 951 CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_ttilyr%cldes if not exchanging category fields' ) 952 ENDIF 953 ENDIF 954 CASE ( 'weighted ice' ) 955 ssnd(jps_ttilyr)%laction = .TRUE. 956 IF( TRIM( sn_snd_ttilyr%clcat ) == 'yes' ) ssnd(jps_ttilyr)%nct = nn_cats_cpl 957 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_ttilyr%cldes;'//sn_snd_ttilyr%cldes ) 958 END SELECT 959 960 ssnd(jps_kice )%clname = 'OIceKn' 961 SELECT CASE ( TRIM( sn_snd_cond%cldes ) ) 962 CASE ( 'none' ) 963 ssnd(jps_kice)%laction = .FALSE. 964 CASE ( 'ice only' ) 965 ssnd(jps_kice)%laction = .TRUE. 966 IF( TRIM( sn_snd_cond%clcat ) == 'yes' ) THEN 967 ssnd(jps_kice)%nct = nn_cats_cpl 968 ELSE 969 IF( nn_cats_cpl > 1 ) THEN 970 CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_cond%cldes if not exchanging category fields' ) 971 ENDIF 972 ENDIF 973 CASE ( 'weighted ice' ) 974 ssnd(jps_kice)%laction = .TRUE. 975 IF( TRIM( sn_snd_cond%clcat ) == 'yes' ) ssnd(jps_kice)%nct = nn_cats_cpl 976 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_cond%cldes;'//sn_snd_cond%cldes ) 977 END SELECT 978 ! 979 ! ! ------------------------- ! 980 ! ! Sea surface height ! 981 ! ! ------------------------- ! 982 ssnd(jps_wlev)%clname = 'O_Wlevel' ; IF( TRIM(sn_snd_wlev%cldes) == 'coupled' ) ssnd(jps_wlev)%laction = .TRUE. 941 ! Note that ultimately we will move to passing an ocean effective conductivity as well so there 942 ! will be some changes to the parts of the code which currently relate only to ice conductivity 943 ssnd(jps_ttilyr )%clname = 'O_TtiLyr' 944 SELECT CASE ( TRIM( sn_snd_ttilyr%cldes ) ) 945 CASE ( 'none' ) 946 ssnd(jps_ttilyr)%laction = .FALSE. 947 CASE ( 'ice only' ) 948 ssnd(jps_ttilyr)%laction = .TRUE. 949 IF( TRIM( sn_snd_ttilyr%clcat ) == 'yes' ) THEN 950 ssnd(jps_ttilyr)%nct = nn_cats_cpl 951 ELSE 952 IF( nn_cats_cpl > 1 ) THEN 953 CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_ttilyr%cldes if not exchanging category fields' ) 954 ENDIF 955 ENDIF 956 CASE ( 'weighted ice' ) 957 ssnd(jps_ttilyr)%laction = .TRUE. 958 IF( TRIM( sn_snd_ttilyr%clcat ) == 'yes' ) ssnd(jps_ttilyr)%nct = nn_cats_cpl 959 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_ttilyr%cldes;'//sn_snd_ttilyr%cldes ) 960 END SELECT 961 962 ssnd(jps_kice )%clname = 'OIceKn' 963 SELECT CASE ( TRIM( sn_snd_cond%cldes ) ) 964 CASE ( 'none' ) 965 ssnd(jps_kice)%laction = .FALSE. 966 CASE ( 'ice only' ) 967 ssnd(jps_kice)%laction = .TRUE. 968 IF( TRIM( sn_snd_cond%clcat ) == 'yes' ) THEN 969 ssnd(jps_kice)%nct = nn_cats_cpl 970 ELSE 971 IF( nn_cats_cpl > 1 ) THEN 972 CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_cond%cldes if not exchanging category fields' ) 973 ENDIF 974 ENDIF 975 CASE ( 'weighted ice' ) 976 ssnd(jps_kice)%laction = .TRUE. 977 IF( TRIM( sn_snd_cond%clcat ) == 'yes' ) ssnd(jps_kice)%nct = nn_cats_cpl 978 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_cond%cldes;'//sn_snd_cond%cldes ) 979 END SELECT 980 ! 981 ! ! ------------------------- ! 982 ! ! Sea surface height ! 983 ! ! ------------------------- ! 984 ssnd(jps_wlev)%clname = 'O_Wlevel' ; IF( TRIM(sn_snd_wlev%cldes) == 'coupled' ) ssnd(jps_wlev)%laction = .TRUE. 983 985 984 986 ! ! ------------------------------- ! 985 ! ! OPA-SAS coupling - snd by opa ! 987 ! ! OPA-SAS coupling - snd by opa ! 986 988 ! ! ------------------------------- ! 987 ssnd(jps_ssh )%clname = 'O_SSHght' 988 ssnd(jps_soce )%clname = 'O_SSSal' 989 ssnd(jps_e3t1st)%clname = 'O_E3T1st' 989 ssnd(jps_ssh )%clname = 'O_SSHght' 990 ssnd(jps_soce )%clname = 'O_SSSal' 991 ssnd(jps_e3t1st)%clname = 'O_E3T1st' 990 992 ssnd(jps_fraqsr)%clname = 'O_FraQsr' 991 993 ! … … 1005 1007 WRITE(numout,*)' sent fields to SAS component ' 1006 1008 WRITE(numout,*)' sea surface temperature (T before, Celsius) ' 1007 WRITE(numout,*)' sea surface salinity ' 1008 WRITE(numout,*)' surface currents U,V on local grid and spherical coordinates' 1009 WRITE(numout,*)' sea surface height ' 1010 WRITE(numout,*)' thickness of first ocean T level ' 1009 WRITE(numout,*)' sea surface salinity ' 1010 WRITE(numout,*)' surface currents U,V on local grid and spherical coordinates' 1011 WRITE(numout,*)' sea surface height ' 1012 WRITE(numout,*)' thickness of first ocean T level ' 1011 1013 WRITE(numout,*)' fraction of solar net radiation absorbed in the first ocean level' 1012 1014 WRITE(numout,*) … … 1014 1016 ENDIF 1015 1017 ! ! ------------------------------- ! 1016 ! ! OPA-SAS coupling - snd by sas ! 1018 ! ! OPA-SAS coupling - snd by sas ! 1017 1019 ! ! ------------------------------- ! 1018 ssnd(jps_sflx )%clname = 'I_SFLX' 1020 ssnd(jps_sflx )%clname = 'I_SFLX' 1019 1021 ssnd(jps_fice2 )%clname = 'IIceFrc' 1020 ssnd(jps_qsroce)%clname = 'I_QsrOce' 1021 ssnd(jps_qnsoce)%clname = 'I_QnsOce' 1022 ssnd(jps_oemp )%clname = 'IOEvaMPr' 1023 ssnd(jps_otx1 )%clname = 'I_OTaux1' 1024 ssnd(jps_oty1 )%clname = 'I_OTauy1' 1025 ssnd(jps_rnf )%clname = 'I_Runoff' 1026 ssnd(jps_taum )%clname = 'I_TauMod' 1022 ssnd(jps_qsroce)%clname = 'I_QsrOce' 1023 ssnd(jps_qnsoce)%clname = 'I_QnsOce' 1024 ssnd(jps_oemp )%clname = 'IOEvaMPr' 1025 ssnd(jps_otx1 )%clname = 'I_OTaux1' 1026 ssnd(jps_oty1 )%clname = 'I_OTauy1' 1027 ssnd(jps_rnf )%clname = 'I_Runoff' 1028 ssnd(jps_taum )%clname = 'I_TauMod' 1027 1029 ! 1028 1030 IF( nn_components == jp_iam_sas ) THEN … … 1060 1062 1061 1063 CALL cpl_define(jprcv, jpsnd, nn_cplmodel) 1062 1063 IF(ln_usecplmask) THEN 1064 1065 IF(ln_usecplmask) THEN 1064 1066 xcplmask(:,:,:) = 0. 1065 1067 CALL iom_open( 'cplmask', inum ) … … 1075 1077 1076 1078 1077 SUBROUTINE sbc_cpl_rcv( kt, k_fsbc, k_ice, Kbb, Kmm ) 1079 SUBROUTINE sbc_cpl_rcv( kt, k_fsbc, k_ice, Kbb, Kmm ) 1078 1080 !!---------------------------------------------------------------------- 1079 1081 !! *** ROUTINE sbc_cpl_rcv *** … … 1089 1091 !! 1090 1092 !! - transform the received ocean stress vector from the received 1091 !! referential and grid into an atmosphere-ocean stress in 1092 !! the (i,j) ocean referencial and at the ocean velocity point. 1093 !! referential and grid into an atmosphere-ocean stress in 1094 !! the (i,j) ocean referencial and at the ocean velocity point. 1093 1095 !! The received stress are : 1094 1096 !! - defined by 3 components (if cartesian coordinate) … … 1098 1100 !! - given at U- and V-point, resp. if received on 2 grids 1099 1101 !! or at T-point if received on 1 grid 1100 !! Therefore and if necessary, they are successively 1101 !! processed in order to obtain them 1102 !! first as 2 components on the sphere 1102 !! Therefore and if necessary, they are successively 1103 !! processed in order to obtain them 1104 !! first as 2 components on the sphere 1103 1105 !! second as 2 components oriented along the local grid 1104 !! third as 2 components on the U,V grid 1106 !! third as 2 components on the U,V grid 1105 1107 !! 1106 !! --> 1108 !! --> 1107 1109 !! 1108 !! - In 'ocean only' case, non solar and solar ocean heat fluxes 1109 !! and total ocean freshwater fluxes 1110 !! - In 'ocean only' case, non solar and solar ocean heat fluxes 1111 !! and total ocean freshwater fluxes 1110 1112 !! 1111 !! ** Method : receive all fields from the atmosphere and transform 1112 !! them into ocean surface boundary condition fields 1113 !! ** Method : receive all fields from the atmosphere and transform 1114 !! them into ocean surface boundary condition fields 1113 1115 !! 1114 !! ** Action : update utau, vtau ocean stress at U,V grid 1116 !! ** Action : update utau, vtau ocean stress at U,V grid 1115 1117 !! taum wind stress module at T-point 1116 1118 !! wndm wind speed module at T-point over free ocean or leads in presence of sea-ice … … 1123 1125 ! 1124 1126 INTEGER, INTENT(in) :: kt ! ocean model time step index 1125 INTEGER, INTENT(in) :: k_fsbc ! frequency of sbc (-> ice model) computation 1127 INTEGER, INTENT(in) :: k_fsbc ! frequency of sbc (-> ice model) computation 1126 1128 INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3) 1127 1129 INTEGER, INTENT(in) :: Kbb, Kmm ! ocean model time level indices … … 1130 1132 INTEGER :: ji, jj, jn ! dummy loop indices 1131 1133 INTEGER :: isec ! number of seconds since nit000 (assuming rdt did not change since nit000) 1132 REAL(wp) :: zcumulneg, zcumulpos ! temporary scalars 1134 REAL(wp) :: zcumulneg, zcumulpos ! temporary scalars 1133 1135 REAL(wp) :: zcoef ! temporary scalar 1134 1136 REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 … … 1145 1147 1146 1148 IF( ncpl_qsr_freq /= 0) ncpl_qsr_freq = 86400 / ncpl_qsr_freq ! used by top 1147 1149 1148 1150 ENDIF 1149 1151 ! … … 1184 1186 IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid 1185 1187 ! ! (geographical to local grid -> rotate the components) 1186 CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx ) 1188 CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx ) 1187 1189 IF( srcv(jpr_otx2)%laction ) THEN 1188 CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty ) 1190 CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty ) 1189 1191 ELSE 1190 CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty ) 1192 CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty ) 1191 1193 ENDIF 1192 1194 frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid 1193 1195 frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 2nd grid 1194 1196 ENDIF 1195 ! 1197 ! 1196 1198 IF( srcv(jpr_otx1)%clgrid == 'T' ) THEN 1197 1199 DO_2D( 0, 0, 0, 0 ) ! T ==> (U,V) … … 1208 1210 ELSE ! No dynamical coupling ! 1209 1211 ! ! ========================= ! 1210 frcv(jpr_otx1)%z3(:,:,1) = 0.e0 ! here simply set to zero 1212 frcv(jpr_otx1)%z3(:,:,1) = 0.e0 ! here simply set to zero 1211 1213 frcv(jpr_oty1)%z3(:,:,1) = 0.e0 ! an external read in a file can be added instead 1212 1214 llnewtx = .TRUE. … … 1216 1218 ! ! wind stress module ! (taum) 1217 1219 ! ! ========================= ! 1218 IF( .NOT. srcv(jpr_taum)%laction ) THEN ! compute wind stress module from its components if not received 1220 IF( .NOT. srcv(jpr_taum)%laction ) THEN ! compute wind stress module from its components if not received 1219 1221 ! => need to be done only when otx1 was changed 1220 1222 IF( llnewtx ) THEN … … 1232 1234 llnewtau = nrcvinfo(jpr_taum) == OASIS_Rcv 1233 1235 ! Stress module can be negative when received (interpolation problem) 1234 IF( llnewtau ) THEN 1236 IF( llnewtau ) THEN 1235 1237 frcv(jpr_taum)%z3(:,:,1) = MAX( 0._wp, frcv(jpr_taum)%z3(:,:,1) ) 1236 1238 ENDIF … … 1240 1242 ! ! 10 m wind speed ! (wndm) 1241 1243 ! ! ========================= ! 1242 IF( .NOT. srcv(jpr_w10m)%laction ) THEN ! compute wind spreed from wind stress module if not received 1244 IF( .NOT. srcv(jpr_w10m)%laction ) THEN ! compute wind spreed from wind stress module if not received 1243 1245 ! => need to be done only when taumod was changed 1244 IF( llnewtau ) THEN 1245 zcoef = 1. / ( zrhoa * zcdrag ) 1246 IF( llnewtau ) THEN 1247 zcoef = 1. / ( zrhoa * zcdrag ) 1246 1248 DO_2D( 1, 1, 1, 1 ) 1247 1249 frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) … … 1263 1265 ! ! ========================= ! 1264 1266 ! u(v)tau and taum will be modified by ice model 1265 ! -> need to be reset before each call of the ice/fsbc 1267 ! -> need to be reset before each call of the ice/fsbc 1266 1268 IF( MOD( kt-1, k_fsbc ) == 0 ) THEN 1267 1269 ! … … 1278 1280 ENDIF 1279 1281 CALL iom_put( "taum_oce", taum ) ! output wind stress module 1280 ! 1282 ! 1281 1283 ENDIF 1282 1284 … … 1286 1288 IF( srcv(jpr_co2)%laction ) atm_co2(:,:) = frcv(jpr_co2)%z3(:,:,1) 1287 1289 ! 1288 ! ! ========================= ! 1289 ! ! Mean Sea Level Pressure ! (taum) 1290 ! ! ========================= ! 1291 IF( srcv(jpr_mslp)%laction ) THEN ! UKMO SHELF effect of atmospheric pressure on SSH 1292 IF( kt /= nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) !* Swap of ssh_ib fields 1293 1294 r1_grau = 1.e0 / (grav * rho0) !* constant for optimization 1295 ssh_ib(:,:) = - ( frcv(jpr_mslp)%z3(:,:,1) - rpref ) * r1_grau ! equivalent ssh (inverse barometer) 1296 apr (:,:) = frcv(jpr_mslp)%z3(:,:,1) !atmospheric pressure 1297 1298 IF( kt == nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) ! correct this later (read from restart if possible) 1299 ENDIF 1290 ! ! ========================= ! 1291 ! ! Mean Sea Level Pressure ! (taum) 1292 ! ! ========================= ! 1293 IF( srcv(jpr_mslp)%laction ) THEN ! UKMO SHELF effect of atmospheric pressure on SSH 1294 IF( kt /= nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) !* Swap of ssh_ib fields 1295 1296 r1_grau = 1.e0 / (grav * rho0) !* constant for optimization 1297 ssh_ib(:,:) = - ( frcv(jpr_mslp)%z3(:,:,1) - rpref ) * r1_grau ! equivalent ssh (inverse barometer) 1298 apr (:,:) = frcv(jpr_mslp)%z3(:,:,1) !atmospheric pressure 1299 1300 IF( kt == nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) ! correct this later (read from restart if possible) 1301 ENDIF 1300 1302 ! 1301 1303 IF( ln_sdw ) THEN ! Stokes Drift correction activated 1302 ! ! ========================= ! 1304 ! ! ========================= ! 1303 1305 ! ! Stokes drift u ! 1304 ! ! ========================= ! 1306 ! ! ========================= ! 1305 1307 IF( srcv(jpr_sdrftx)%laction ) ut0sd(:,:) = frcv(jpr_sdrftx)%z3(:,:,1) 1306 1308 ! 1307 ! ! ========================= ! 1309 ! ! ========================= ! 1308 1310 ! ! Stokes drift v ! 1309 ! ! ========================= ! 1311 ! ! ========================= ! 1310 1312 IF( srcv(jpr_sdrfty)%laction ) vt0sd(:,:) = frcv(jpr_sdrfty)%z3(:,:,1) 1311 1313 ! 1312 ! ! ========================= ! 1314 ! ! ========================= ! 1313 1315 ! ! Wave mean period ! 1314 ! ! ========================= ! 1316 ! ! ========================= ! 1315 1317 IF( srcv(jpr_wper)%laction ) wmp(:,:) = frcv(jpr_wper)%z3(:,:,1) 1316 1318 ! 1317 ! ! ========================= ! 1319 ! ! ========================= ! 1318 1320 ! ! Significant wave height ! 1319 ! ! ========================= ! 1321 ! ! ========================= ! 1320 1322 IF( srcv(jpr_hsig)%laction ) hsw(:,:) = frcv(jpr_hsig)%z3(:,:,1) 1321 ! 1322 ! ! ========================= ! 1323 ! ! Wave peak frequency ! 1324 ! ! ========================= ! 1323 ! 1324 ! ! ========================= ! 1325 ! ! Wave peak frequency ! 1326 ! ! ========================= ! 1325 1327 IF( srcv(jpr_wfreq)%laction ) wfreq(:,:) = frcv(jpr_wfreq)%z3(:,:,1) 1326 1328 ! 1327 ! ! ========================= ! 1329 ! ! ========================= ! 1328 1330 ! ! Vertical mixing Qiao ! 1329 ! ! ========================= ! 1331 ! ! ========================= ! 1330 1332 IF( srcv(jpr_wnum)%laction .AND. ln_zdfswm ) wnum(:,:) = frcv(jpr_wnum)%z3(:,:,1) 1331 1333 … … 1336 1338 ENDIF 1337 1339 ENDIF 1338 ! ! ========================= ! 1340 ! ! ========================= ! 1339 1341 ! ! Stress adsorbed by waves ! 1340 ! ! ========================= ! 1342 ! ! ========================= ! 1341 1343 IF( srcv(jpr_tauwoc)%laction .AND. ln_tauwoc ) tauoc_wave(:,:) = frcv(jpr_tauwoc)%z3(:,:,1) 1342 1344 1343 ! ! ========================= ! 1344 ! ! Stress component by waves ! 1345 ! ! ========================= ! 1345 ! ! ========================= ! 1346 ! ! Stress component by waves ! 1347 ! ! ========================= ! 1346 1348 IF( srcv(jpr_tauwx)%laction .AND. srcv(jpr_tauwy)%laction .AND. ln_tauw ) THEN 1347 1349 tauw_x(:,:) = frcv(jpr_tauwx)%z3(:,:,1) … … 1349 1351 ENDIF 1350 1352 1351 ! ! ========================= ! 1353 ! ! ========================= ! 1352 1354 ! ! Wave drag coefficient ! 1353 ! ! ========================= ! 1355 ! ! ========================= ! 1354 1356 IF( srcv(jpr_wdrag)%laction .AND. ln_cdgw ) cdn_wave(:,:) = frcv(jpr_wdrag)%z3(:,:,1) 1355 1357 … … 1363 1365 CALL iom_put( 'sss_m', sss_m ) 1364 1366 ENDIF 1365 ! 1367 ! 1366 1368 ! ! ================== ! 1367 1369 ! ! SST ! … … 1409 1411 CALL iom_put( 'frq_m', frq_m ) 1410 1412 ENDIF 1411 1413 1412 1414 ! ! ========================= ! 1413 1415 IF( k_ice <= 1 .AND. MOD( kt-1, k_fsbc ) == 0 ) THEN ! heat & freshwater fluxes ! (Ocean only case) … … 1431 1433 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 1432 1434 IF( srcv(jpr_cal)%laction ) zemp(:,:) = zemp(:,:) - frcv(jpr_cal)%z3(:,:,1) 1433 1434 IF( srcv(jpr_icb)%laction ) THEN 1435 1436 IF( srcv(jpr_icb)%laction ) THEN 1435 1437 fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) 1436 1438 rnf(:,:) = rnf(:,:) + fwficb(:,:) ! iceberg added to runfofs … … 1439 1441 ! ice shelf fwf 1440 1442 IF( srcv(jpr_isf)%laction ) THEN 1441 fwfisf_oasis(:,:) = - frcv(jpr_isf)%z3(:,:,1) ! fresh water flux from the isf (fwfisf <0 mean melting) 1443 fwfisf_oasis(:,:) = - frcv(jpr_isf)%z3(:,:,1) ! fresh water flux from the isf (fwfisf <0 mean melting) 1442 1444 END IF 1443 1445 1444 1446 IF( ln_mixcpl ) THEN ; emp(:,:) = emp(:,:) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:) 1445 1447 ELSE ; emp(:,:) = zemp(:,:) … … 1483 1485 ! 1484 1486 END SUBROUTINE sbc_cpl_rcv 1485 1486 1487 SUBROUTINE sbc_cpl_ice_tau( p_taui, p_tauj ) 1487 1488 1489 SUBROUTINE sbc_cpl_ice_tau( p_taui, p_tauj ) 1488 1490 !!---------------------------------------------------------------------- 1489 1491 !! *** ROUTINE sbc_cpl_ice_tau *** 1490 1492 !! 1491 !! ** Purpose : provide the stress over sea-ice in coupled mode 1493 !! ** Purpose : provide the stress over sea-ice in coupled mode 1492 1494 !! 1493 1495 !! ** Method : transform the received stress from the atmosphere into 1494 1496 !! an atmosphere-ice stress in the (i,j) ocean referencial 1495 1497 !! and at the velocity point of the sea-ice model: 1496 !! 'C'-grid : i- (j-) components given at U- (V-) point 1498 !! 'C'-grid : i- (j-) components given at U- (V-) point 1497 1499 !! 1498 1500 !! The received stress are : … … 1503 1505 !! - given at U- and V-point, resp. if received on 2 grids 1504 1506 !! or at a same point (T or I) if received on 1 grid 1505 !! Therefore and if necessary, they are successively 1506 !! processed in order to obtain them 1507 !! first as 2 components on the sphere 1507 !! Therefore and if necessary, they are successively 1508 !! processed in order to obtain them 1509 !! first as 2 components on the sphere 1508 1510 !! second as 2 components oriented along the local grid 1509 !! third as 2 components on the ice grid point 1511 !! third as 2 components on the ice grid point 1510 1512 !! 1511 !! Except in 'oce and ice' case, only one vector stress field 1513 !! Except in 'oce and ice' case, only one vector stress field 1512 1514 !! is received. It has already been processed in sbc_cpl_rcv 1513 1515 !! so that it is now defined as (i,j) components given at U- 1514 !! and V-points, respectively. 1516 !! and V-points, respectively. 1515 1517 !! 1516 1518 !! ** Action : return ptau_i, ptau_j, the stress over the ice … … 1522 1524 INTEGER :: itx ! index of taux over ice 1523 1525 REAL(wp) :: zztmp1, zztmp2 1524 REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty 1526 REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty 1525 1527 !!---------------------------------------------------------------------- 1526 1528 ! 1527 IF( srcv(jpr_itx1)%laction ) THEN ; itx = jpr_itx1 1529 IF( srcv(jpr_itx1)%laction ) THEN ; itx = jpr_itx1 1528 1530 ELSE ; itx = jpr_otx1 1529 1531 ENDIF … … 1534 1536 IF( srcv(jpr_itx1)%laction ) THEN ! ice stress received ! 1535 1537 ! ! ======================= ! 1536 ! 1538 ! 1537 1539 IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere 1538 1540 ! ! (cartesian to spherical -> 3 to 2 components) … … 1553 1555 IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid 1554 1556 ! ! (geographical to local grid -> rotate the components) 1555 CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->i', ztx ) 1557 CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->i', ztx ) 1556 1558 IF( srcv(jpr_itx2)%laction ) THEN 1557 CALL rot_rep( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), srcv(jpr_itx2)%clgrid, 'en->j', zty ) 1559 CALL rot_rep( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), srcv(jpr_itx2)%clgrid, 'en->j', zty ) 1558 1560 ELSE 1559 CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->j', zty ) 1561 CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->j', zty ) 1560 1562 ENDIF 1561 1563 frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid … … 1572 1574 ! ! put on ice grid ! 1573 1575 ! ! ======================= ! 1574 ! 1576 ! 1575 1577 ! j+1 j -----V---F 1576 1578 ! ice stress on ice velocity point ! | … … 1587 1589 CASE( 'T' ) 1588 1590 DO_2D( 0, 0, 0, 0 ) ! T ==> (U,V) 1589 ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology 1591 ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology 1590 1592 zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) 1591 1593 zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) ) … … 1595 1597 CALL lbc_lnk_multi( 'sbccpl', p_taui, 'U', -1., p_tauj, 'V', -1. ) 1596 1598 END SELECT 1597 1599 1598 1600 ENDIF 1599 1601 ! 1600 1602 END SUBROUTINE sbc_cpl_ice_tau 1601 1603 1602 1604 1603 1605 SUBROUTINE sbc_cpl_ice_flx( picefr, palbi, psst, pist, phs, phi ) … … 1608 1610 !! 1609 1611 !! ** Method : transform the fields received from the atmosphere into 1610 !! surface heat and fresh water boundary condition for the 1612 !! surface heat and fresh water boundary condition for the 1611 1613 !! ice-ocean system. The following fields are provided: 1612 !! * total non solar, solar and freshwater fluxes (qns_tot, 1614 !! * total non solar, solar and freshwater fluxes (qns_tot, 1613 1615 !! qsr_tot and emp_tot) (total means weighted ice-ocean flux) 1614 1616 !! NB: emp_tot include runoffs and calving. 1615 1617 !! * fluxes over ice (qns_ice, qsr_ice, emp_ice) where 1616 1618 !! emp_ice = sublimation - solid precipitation as liquid 1617 !! precipitation are re-routed directly to the ocean and 1619 !! precipitation are re-routed directly to the ocean and 1618 1620 !! calving directly enter the ocean (runoffs are read but included in trasbc.F90) 1619 !! * solid precipitation (sprecip), used to add to qns_tot 1621 !! * solid precipitation (sprecip), used to add to qns_tot 1620 1622 !! the heat lost associated to melting solid precipitation 1621 1623 !! over the ocean fraction. … … 1649 1651 !! emp_ice ice sublimation - solid precipitation over the ice 1650 1652 !! dqns_ice d(non-solar heat flux)/d(Temperature) over the ice 1651 !! sprecip solid precipitation over the ocean 1653 !! sprecip solid precipitation over the ocean 1652 1654 !!---------------------------------------------------------------------- 1653 1655 REAL(wp), INTENT(in) , DIMENSION(:,:) :: picefr ! ice fraction [0 to 1] 1654 1656 ! !! ! optional arguments, used only in 'mixed oce-ice' case or for Met-Office coupling 1655 REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo 1657 REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo 1656 1658 REAL(wp), INTENT(in) , DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius] 1657 1659 REAL(wp), INTENT(inout), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] => inout for Met-Office … … 1690 1692 zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 1691 1693 ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 1692 CASE( 'none' ) ! Not available as for now: needs additional coding below when computing zevap_oce 1694 CASE( 'none' ) ! Not available as for now: needs additional coding below when computing zevap_oce 1693 1695 ! ! since fields received are not defined with none option 1694 1696 CALL ctl_stop( 'STOP', 'sbccpl/sbc_cpl_ice_flx: some fields are not defined. Change sn_rcv_emp value in namelist namsbc_cpl' ) … … 1737 1739 ! zsnw = snow fraction over ice after wind blowing (=picefr if no blowing) 1738 1740 zsnw(:,:) = 0._wp ; CALL ice_var_snwblow( ziceld, zsnw ) 1739 1741 1740 1742 ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! 1741 1743 zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( picefr(:,:) - zsnw(:,:) ) ! emp_ice = A * sublimation - zsnw * sprecip … … 1748 1750 ! therefore, sublimation is not redistributed over the ice categories when no subgrid scale fluxes are provided by atm. 1749 1751 zdevap_ice(:,:) = 0._wp 1750 1752 1751 1753 ! --- Continental fluxes --- ! 1752 1754 IF( srcv(jpr_rnf)%laction ) THEN ! runoffs (included in emp later on) … … 1762 1764 ENDIF 1763 1765 IF( srcv(jpr_isf)%laction ) THEN ! iceshelf (fwfisf <0 mean melting) 1764 fwfisf_oasis(:,:) = - frcv(jpr_isf)%z3(:,:,1) 1766 fwfisf_oasis(:,:) = - frcv(jpr_isf)%z3(:,:,1) 1765 1767 ENDIF 1766 1768 … … 1778 1780 emp_tot (:,:) = zemp_tot (:,:) 1779 1781 emp_ice (:,:) = zemp_ice (:,:) 1780 emp_oce (:,:) = zemp_oce (:,:) 1782 emp_oce (:,:) = zemp_oce (:,:) 1781 1783 sprecip (:,:) = zsprecip (:,:) 1782 1784 tprecip (:,:) = ztprecip (:,:) … … 1825 1827 IF( iom_use('snowpre') ) CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow 1826 1828 IF( iom_use('precip') ) CALL iom_put( 'precip' , tprecip(:,:) ) ! total precipitation 1827 IF( iom_use('rain') ) CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation 1829 IF( iom_use('rain') ) CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation 1828 1830 IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average) 1829 1831 IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea' , sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average) … … 1841 1843 ! For Met Office sea ice non-solar fluxes are already delt with by JULES so setting to zero 1842 1844 ! here so the only flux is the ocean only one. 1843 zqns_ice(:,:,:) = 0._wp 1845 zqns_ice(:,:,:) = 0._wp 1844 1846 CASE( 'conservative' ) ! the required fields are directly provided 1845 1847 zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) … … 1855 1857 IF( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 1856 1858 DO jl=1,jpl 1857 zqns_tot(:,: ) = zqns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl) 1859 zqns_tot(:,: ) = zqns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl) 1858 1860 zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl) 1859 1861 ENDDO … … 1881 1883 ENDIF 1882 1884 END SELECT 1883 ! 1885 ! 1884 1886 ! --- calving (removed from qns_tot) --- ! 1885 1887 IF( srcv(jpr_cal)%laction ) zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * rLfus ! remove latent heat of calving … … 1888 1890 IF( srcv(jpr_icb)%laction ) zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_icb)%z3(:,:,1) * rLfus ! remove latent heat of iceberg melting 1889 1891 1890 #if defined key_si3 1892 #if defined key_si3 1891 1893 ! --- non solar flux over ocean --- ! 1892 1894 ! note: ziceld cannot be = 0 since we limit the ice concentration to amax … … 1899 1901 ENDWHERE 1900 1902 ! Heat content per unit mass of rain (J/kg) 1901 zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) - rt0) * a_i(:,:,:), dim=3 ) + sst_m(:,:) * ziceld(:,:) ) 1903 zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) - rt0) * a_i(:,:,:), dim=3 ) + sst_m(:,:) * ziceld(:,:) ) 1902 1904 1903 1905 ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! … … 1916 1918 !! zqemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * zcptsnw (:,:) & ! ice evap 1917 1919 !! & + zsprecip(:,:) * zsnw * zqprec_ice(:,:) * r1_rhos ! solid precip over ice 1918 1920 1919 1921 ! --- total non solar flux (including evap/precip) --- ! 1920 1922 zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:) 1921 1923 1922 ! --- in case both coupled/forced are active, we must mix values --- ! 1924 ! --- in case both coupled/forced are active, we must mix values --- ! 1923 1925 IF( ln_mixcpl ) THEN 1924 1926 qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) + zqns_tot(:,:)* zmsk(:,:) … … 1944 1946 zcptsnw (:,:) = zcptn(:,:) 1945 1947 zcptrain(:,:) = zcptn(:,:) 1946 1948 1947 1949 ! clem: this formulation is certainly wrong... but better than it was... 1948 1950 zqns_tot(:,:) = zqns_tot(:,:) & ! zqns_tot update over free ocean with: 1949 1951 & - ( ziceld(:,:) * zsprecip(:,:) * rLfus ) & ! remove the latent heat flux of solid precip. melting 1950 1952 & - ( zemp_tot(:,:) & ! remove the heat content of mass flux (assumed to be at SST) 1951 & - zemp_ice(:,:) ) * zcptn(:,:) 1953 & - zemp_ice(:,:) ) * zcptn(:,:) 1952 1954 1953 1955 IF( ln_mixcpl ) THEN … … 1974 1976 IF( iom_use('hflx_snow_ao_cea') ) CALL iom_put('hflx_snow_ao_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) & 1975 1977 & * ( 1._wp - zsnw(:,:) ) ) ! heat flux from snow (over ocean) 1976 IF( iom_use('hflx_snow_ai_cea') ) CALL iom_put('hflx_snow_ai_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) & 1978 IF( iom_use('hflx_snow_ai_cea') ) CALL iom_put('hflx_snow_ai_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) & 1977 1979 & * zsnw(:,:) ) ! heat flux from snow (over ice) 1978 1980 ! note: hflx for runoff and iceshelf are done in sbcrnf and sbcisf resp. … … 2000 2002 IF( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN 2001 2003 DO jl = 1, jpl 2002 zqsr_tot(:,: ) = zqsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl) 2004 zqsr_tot(:,: ) = zqsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl) 2003 2005 zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl) 2004 2006 END DO … … 2027 2029 END DO 2028 2030 ENDIF 2029 CASE( 'none' ) ! Not available as for now: needs additional coding 2031 CASE( 'none' ) ! Not available as for now: needs additional coding 2030 2032 ! ! since fields received, here zqsr_tot, are not defined with none option 2031 2033 CALL ctl_stop( 'STOP', 'sbccpl/sbc_cpl_ice_flx: some fields are not defined. Change sn_rcv_qsr value in namelist namsbc_cpl' ) … … 2071 2073 ENDDO 2072 2074 ENDIF 2073 CASE( 'none' ) 2075 CASE( 'none' ) 2074 2076 zdqns_ice(:,:,:) = 0._wp 2075 2077 END SELECT 2076 2078 2077 2079 IF( ln_mixcpl ) THEN 2078 2080 DO jl=1,jpl … … 2083 2085 ENDIF 2084 2086 2085 #if defined key_si3 2087 #if defined key_si3 2086 2088 ! ! ========================= ! 2087 2089 SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) ) ! ice topmelt and botmelt ! … … 2115 2117 ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm 2116 2118 DO jl = 1, jpl 2117 WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm 2119 WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm 2118 2120 zqtr_ice_top(:,:,jl) = zqsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) 2119 2121 ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm 2120 2122 zqtr_ice_top(:,:,jl) = zqsr_ice(:,:,jl) * ztri(:,:) 2121 2123 ELSEWHERE ! zero when hs>0 2122 zqtr_ice_top(:,:,jl) = 0._wp 2124 zqtr_ice_top(:,:,jl) = 0._wp 2123 2125 END WHERE 2124 2126 ENDDO … … 2129 2131 zqtr_ice_top(:,:,:) = 0.3_wp * zqsr_ice(:,:,:) 2130 2132 ENDIF 2131 ! 2133 ! 2132 2134 ELSEIF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN !== conduction flux as surface forcing ==! 2133 2135 ! … … 2149 2151 ! ! ================== ! 2150 2152 ! needed by Met Office 2151 IF( srcv(jpr_ts_ice)%laction ) THEN 2152 WHERE ( frcv(jpr_ts_ice)%z3(:,:,:) > 0.0 ) ; ztsu(:,:,:) = 0. + rt0 2153 IF( srcv(jpr_ts_ice)%laction ) THEN 2154 WHERE ( frcv(jpr_ts_ice)%z3(:,:,:) > 0.0 ) ; ztsu(:,:,:) = 0. + rt0 2153 2155 ELSEWHERE( frcv(jpr_ts_ice)%z3(:,:,:) < -60. ) ; ztsu(:,:,:) = -60. + rt0 2154 2156 ELSEWHERE ; ztsu(:,:,:) = frcv(jpr_ts_ice)%z3(:,:,:) + rt0 … … 2168 2170 ! 2169 2171 END SUBROUTINE sbc_cpl_ice_flx 2170 2171 2172 2173 2172 2174 SUBROUTINE sbc_cpl_snd( kt, Kbb, Kmm ) 2173 2175 !!---------------------------------------------------------------------- … … 2186 2188 REAL(wp) :: zumax, zvmax 2187 2189 REAL(wp), DIMENSION(jpi,jpj) :: zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 2188 REAL(wp), DIMENSION(jpi,jpj,jpl) :: ztmp3, ztmp4 2190 REAL(wp), DIMENSION(jpi,jpj,jpl) :: ztmp3, ztmp4 2189 2191 !!---------------------------------------------------------------------- 2190 2192 ! … … 2197 2199 ! ! ------------------------- ! 2198 2200 IF( ssnd(jps_toce)%laction .OR. ssnd(jps_tice)%laction .OR. ssnd(jps_tmix)%laction ) THEN 2199 2201 2200 2202 IF( nn_components == jp_iam_opa ) THEN 2201 2203 ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) ! send temperature as it is (potential or conservative) -> use of l_useCT on the received part 2202 2204 ELSE 2203 ! we must send the surface potential temperature 2205 ! we must send the surface potential temperature 2204 2206 IF( l_useCT ) THEN ; ztmp1(:,:) = eos_pt_from_ct( ts(:,:,1,jp_tem,Kmm), ts(:,:,1,jp_sal,Kmm) ) 2205 2207 ELSE ; ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) … … 2210 2212 CASE( 'oce and ice' ) ; ztmp1(:,:) = ztmp1(:,:) + rt0 2211 2213 SELECT CASE( sn_snd_temp%clcat ) 2212 CASE( 'yes' ) 2214 CASE( 'yes' ) 2213 2215 ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) 2214 2216 CASE( 'no' ) … … 2220 2222 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 2221 2223 END SELECT 2222 CASE( 'weighted oce and ice' ) ; ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) 2224 CASE( 'weighted oce and ice' ) ; ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) 2223 2225 SELECT CASE( sn_snd_temp%clcat ) 2224 CASE( 'yes' ) 2226 CASE( 'yes' ) 2225 2227 ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 2226 2228 CASE( 'no' ) … … 2231 2233 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 2232 2234 END SELECT 2233 CASE( 'oce and weighted ice') ; ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) + rt0 2234 SELECT CASE( sn_snd_temp%clcat ) 2235 CASE( 'yes' ) 2236 ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 2237 CASE( 'no' ) 2238 ztmp3(:,:,:) = 0.0 2239 DO jl=1,jpl 2240 ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) 2241 ENDDO 2242 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 2243 END SELECT 2244 CASE( 'mixed oce-ice' ) 2245 ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) 2235 CASE( 'oce and weighted ice') ; ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) + rt0 2236 SELECT CASE( sn_snd_temp%clcat ) 2237 CASE( 'yes' ) 2238 ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 2239 CASE( 'no' ) 2240 ztmp3(:,:,:) = 0.0 2241 DO jl=1,jpl 2242 ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) 2243 ENDDO 2244 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 2245 END SELECT 2246 CASE( 'mixed oce-ice' ) 2247 ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) 2246 2248 DO jl=1,jpl 2247 2249 ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) … … 2263 2265 SELECT CASE( sn_snd_ttilyr%cldes) 2264 2266 CASE ('weighted ice') 2265 ztmp3(:,:,1:jpl) = t1_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 2267 ztmp3(:,:,1:jpl) = t1_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 2266 2268 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ttilyr%cldes' ) 2267 2269 END SELECT … … 2272 2274 ! ! Albedo ! 2273 2275 ! ! ------------------------- ! 2274 IF( ssnd(jps_albice)%laction ) THEN ! ice 2276 IF( ssnd(jps_albice)%laction ) THEN ! ice 2275 2277 SELECT CASE( sn_snd_alb%cldes ) 2276 2278 CASE( 'ice' ) 2277 2279 SELECT CASE( sn_snd_alb%clcat ) 2278 CASE( 'yes' ) 2280 CASE( 'yes' ) 2279 2281 ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 2280 2282 CASE( 'no' ) … … 2288 2290 CASE( 'weighted ice' ) ; 2289 2291 SELECT CASE( sn_snd_alb%clcat ) 2290 CASE( 'yes' ) 2292 CASE( 'yes' ) 2291 2293 ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 2292 2294 CASE( 'no' ) … … 2302 2304 2303 2305 SELECT CASE( sn_snd_alb%clcat ) 2304 CASE( 'yes' ) 2306 CASE( 'yes' ) 2305 2307 CALL cpl_snd( jps_albice, isec, ztmp3, info ) !-> MV this has never been checked in coupled mode 2306 CASE( 'no' ) 2307 CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 2308 CASE( 'no' ) 2309 CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 2308 2310 END SELECT 2309 2311 ENDIF … … 2317 2319 ENDIF 2318 2320 ! ! ------------------------- ! 2319 ! ! Ice fraction & Thickness ! 2321 ! ! Ice fraction & Thickness ! 2320 2322 ! ! ------------------------- ! 2321 2323 ! Send ice fraction field to atmosphere … … 2330 2332 2331 2333 #if defined key_si3 || defined key_cice 2332 ! If this coupling was successful then save ice fraction for use between coupling points. 2333 ! This is needed for some calculations where the ice fraction at the last coupling point 2334 ! is needed. 2335 IF( info == OASIS_Sent .OR. info == OASIS_ToRest .OR. & 2336 & info == OASIS_SentOut .OR. info == OASIS_ToRestOut ) THEN 2337 IF ( sn_snd_thick%clcat == 'yes' ) THEN 2334 ! If this coupling was successful then save ice fraction for use between coupling points. 2335 ! This is needed for some calculations where the ice fraction at the last coupling point 2336 ! is needed. 2337 IF( info == OASIS_Sent .OR. info == OASIS_ToRest .OR. & 2338 & info == OASIS_SentOut .OR. info == OASIS_ToRestOut ) THEN 2339 IF ( sn_snd_thick%clcat == 'yes' ) THEN 2338 2340 a_i_last_couple(:,:,1:jpl) = a_i(:,:,1:jpl) 2339 2341 ENDIF … … 2349 2351 CALL cpl_snd( jps_fice1, isec, ztmp3, info ) 2350 2352 ENDIF 2351 2353 2352 2354 ! Send ice fraction field to OPA (sent by SAS in SAS-OPA coupling) 2353 2355 IF( ssnd(jps_fice2)%laction ) THEN … … 2356 2358 ENDIF 2357 2359 2358 ! Send ice and snow thickness field 2359 IF( ssnd(jps_hice)%laction .OR. ssnd(jps_hsnw)%laction ) THEN 2360 ! Send ice and snow thickness field 2361 IF( ssnd(jps_hice)%laction .OR. ssnd(jps_hsnw)%laction ) THEN 2360 2362 SELECT CASE( sn_snd_thick%cldes) 2361 2363 CASE( 'none' ) ! nothing to do 2362 CASE( 'weighted ice and snow' ) 2364 CASE( 'weighted ice and snow' ) 2363 2365 SELECT CASE( sn_snd_thick%clcat ) 2364 CASE( 'yes' ) 2366 CASE( 'yes' ) 2365 2367 ztmp3(:,:,1:jpl) = h_i(:,:,1:jpl) * a_i(:,:,1:jpl) 2366 2368 ztmp4(:,:,1:jpl) = h_s(:,:,1:jpl) * a_i(:,:,1:jpl) … … 2373 2375 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 2374 2376 END SELECT 2375 CASE( 'ice and snow' ) 2377 CASE( 'ice and snow' ) 2376 2378 SELECT CASE( sn_snd_thick%clcat ) 2377 2379 CASE( 'yes' ) … … 2396 2398 #if defined key_si3 2397 2399 ! ! ------------------------- ! 2398 ! ! Ice melt ponds ! 2399 ! ! ------------------------- ! 2400 ! needed by Met Office: 1) fraction of ponded ice 2) local/actual pond depth 2401 IF( ssnd(jps_a_p)%laction .OR. ssnd(jps_ht_p)%laction ) THEN 2402 SELECT CASE( sn_snd_mpnd%cldes) 2403 CASE( 'ice only' ) 2404 SELECT CASE( sn_snd_mpnd%clcat ) 2405 CASE( 'yes' ) 2400 ! ! Ice melt ponds ! 2401 ! ! ------------------------- ! 2402 ! needed by Met Office: 1) fraction of ponded ice 2) local/actual pond depth 2403 IF( ssnd(jps_a_p)%laction .OR. ssnd(jps_ht_p)%laction ) THEN 2404 SELECT CASE( sn_snd_mpnd%cldes) 2405 CASE( 'ice only' ) 2406 SELECT CASE( sn_snd_mpnd%clcat ) 2407 CASE( 'yes' ) 2406 2408 ztmp3(:,:,1:jpl) = a_ip_eff(:,:,1:jpl) 2407 ztmp4(:,:,1:jpl) = h_ip(:,:,1:jpl) 2408 CASE( 'no' ) 2409 ztmp3(:,:,:) = 0.0 2410 ztmp4(:,:,:) = 0.0 2411 DO jl=1,jpl 2409 ztmp4(:,:,1:jpl) = h_ip(:,:,1:jpl) 2410 CASE( 'no' ) 2411 ztmp3(:,:,:) = 0.0 2412 ztmp4(:,:,:) = 0.0 2413 DO jl=1,jpl 2412 2414 ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl) 2413 2415 ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl) 2414 ENDDO 2415 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%clcat' ) 2416 END SELECT 2417 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%cldes' ) 2418 END SELECT 2419 IF( ssnd(jps_a_p)%laction ) CALL cpl_snd( jps_a_p , isec, ztmp3, info ) 2420 IF( ssnd(jps_ht_p)%laction ) CALL cpl_snd( jps_ht_p, isec, ztmp4, info ) 2421 ENDIF 2422 ! 2423 ! ! ------------------------- ! 2424 ! ! Ice conductivity ! 2416 ENDDO 2417 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%clcat' ) 2418 END SELECT 2419 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%cldes' ) 2420 END SELECT 2421 IF( ssnd(jps_a_p)%laction ) CALL cpl_snd( jps_a_p , isec, ztmp3, info ) 2422 IF( ssnd(jps_ht_p)%laction ) CALL cpl_snd( jps_ht_p, isec, ztmp4, info ) 2423 ENDIF 2424 ! 2425 ! ! ------------------------- ! 2426 ! ! Ice conductivity ! 2425 2427 ! ! ------------------------- ! 2426 2428 ! needed by Met Office 2427 IF( ssnd(jps_kice)%laction ) THEN 2428 SELECT CASE( sn_snd_cond%cldes) 2429 CASE( 'weighted ice' ) 2430 SELECT CASE( sn_snd_cond%clcat ) 2431 CASE( 'yes' ) 2432 ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 2433 CASE( 'no' ) 2434 ztmp3(:,:,:) = 0.0 2435 DO jl=1,jpl 2436 ztmp3(:,:,1) = ztmp3(:,:,1) + cnd_ice(:,:,jl) * a_i(:,:,jl) 2437 ENDDO 2438 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%clcat' ) 2439 END SELECT 2440 CASE( 'ice only' ) 2441 ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) 2442 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%cldes' ) 2443 END SELECT 2444 IF( ssnd(jps_kice)%laction ) CALL cpl_snd( jps_kice, isec, ztmp3, info ) 2445 ENDIF 2429 IF( ssnd(jps_kice)%laction ) THEN 2430 SELECT CASE( sn_snd_cond%cldes) 2431 CASE( 'weighted ice' ) 2432 SELECT CASE( sn_snd_cond%clcat ) 2433 CASE( 'yes' ) 2434 ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 2435 CASE( 'no' ) 2436 ztmp3(:,:,:) = 0.0 2437 DO jl=1,jpl 2438 ztmp3(:,:,1) = ztmp3(:,:,1) + cnd_ice(:,:,jl) * a_i(:,:,jl) 2439 ENDDO 2440 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%clcat' ) 2441 END SELECT 2442 CASE( 'ice only' ) 2443 ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) 2444 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%cldes' ) 2445 END SELECT 2446 IF( ssnd(jps_kice)%laction ) CALL cpl_snd( jps_kice, isec, ztmp3, info ) 2447 ENDIF 2446 2448 #endif 2447 2449 2448 2450 ! ! ------------------------- ! 2449 ! ! CO2 flux from PISCES ! 2450 ! ! ------------------------- ! 2451 IF( ssnd(jps_co2)%laction .AND. l_co2cpl ) THEN 2451 ! ! CO2 flux from PISCES ! 2452 ! ! ------------------------- ! 2453 IF( ssnd(jps_co2)%laction .AND. l_co2cpl ) THEN 2452 2454 ztmp1(:,:) = oce_co2(:,:) * 1000. ! conversion in molC/m2/s 2453 2455 CALL cpl_snd( jps_co2, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ) , info ) … … 2457 2459 IF( ssnd(jps_ocx1)%laction ) THEN ! Surface current ! 2458 2460 ! ! ------------------------- ! 2459 ! 2461 ! 2460 2462 ! j+1 j -----V---F 2461 2463 ! surface velocity always sent from T point ! | … … 2467 2469 ! i i+1 (for I) 2468 2470 IF( nn_components == jp_iam_opa ) THEN 2469 zotx1(:,:) = uu(:,:,1,Kmm) 2470 zoty1(:,:) = vv(:,:,1,Kmm) 2471 ELSE 2471 zotx1(:,:) = uu(:,:,1,Kmm) 2472 zoty1(:,:) = vv(:,:,1,Kmm) 2473 ELSE 2472 2474 SELECT CASE( TRIM( sn_snd_crt%cldes ) ) 2473 2475 CASE( 'oce only' ) ! C-grid ==> T 2474 2476 DO_2D( 0, 0, 0, 0 ) 2475 2477 zotx1(ji,jj) = 0.5 * ( uu(ji,jj,1,Kmm) + uu(ji-1,jj ,1,Kmm) ) 2476 zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Kmm) + vv(ji ,jj-1,1,Kmm) ) 2478 zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Kmm) + vv(ji ,jj-1,1,Kmm) ) 2477 2479 END_2D 2478 CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T 2480 CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T 2479 2481 DO_2D( 0, 0, 0, 0 ) 2480 zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) 2482 zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) 2481 2483 zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) 2482 2484 zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) … … 2499 2501 IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components 2500 2502 ! ! Ocean component 2501 CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component 2502 CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component 2503 zotx1(:,:) = ztmp1(:,:) ! overwrite the components 2503 CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component 2504 CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component 2505 zotx1(:,:) = ztmp1(:,:) ! overwrite the components 2504 2506 zoty1(:,:) = ztmp2(:,:) 2505 2507 IF( ssnd(jps_ivx1)%laction ) THEN ! Ice component 2506 CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component 2507 CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component 2508 zitx1(:,:) = ztmp1(:,:) ! overwrite the components 2508 CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component 2509 CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component 2510 zitx1(:,:) = ztmp1(:,:) ! overwrite the components 2509 2511 zity1(:,:) = ztmp2(:,:) 2510 2512 ENDIF … … 2531 2533 IF( ssnd(jps_ivy1)%laction ) CALL cpl_snd( jps_ivy1, isec, RESHAPE ( zity1, (/jpi,jpj,1/) ), info ) ! ice y current 1st grid 2532 2534 IF( ssnd(jps_ivz1)%laction ) CALL cpl_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/jpi,jpj,1/) ), info ) ! ice z current 1st grid 2533 ! 2534 ENDIF 2535 ! 2536 ! ! ------------------------- ! 2537 ! ! Surface current to waves ! 2538 ! ! ------------------------- ! 2539 IF( ssnd(jps_ocxw)%laction .OR. ssnd(jps_ocyw)%laction ) THEN 2540 ! 2541 ! j+1 j -----V---F 2542 ! surface velocity always sent from T point ! | 2543 ! j | T U 2544 ! | | 2545 ! j j-1 -I-------| 2546 ! (for I) | | 2547 ! i-1 i i 2548 ! i i+1 (for I) 2549 SELECT CASE( TRIM( sn_snd_crtw%cldes ) ) 2550 CASE( 'oce only' ) ! C-grid ==> T 2535 ! 2536 ENDIF 2537 ! 2538 ! ! ------------------------- ! 2539 ! ! Surface current to waves ! 2540 ! ! ------------------------- ! 2541 IF( ssnd(jps_ocxw)%laction .OR. ssnd(jps_ocyw)%laction ) THEN 2542 ! 2543 ! j+1 j -----V---F 2544 ! surface velocity always sent from T point ! | 2545 ! j | T U 2546 ! | | 2547 ! j j-1 -I-------| 2548 ! (for I) | | 2549 ! i-1 i i 2550 ! i i+1 (for I) 2551 SELECT CASE( TRIM( sn_snd_crtw%cldes ) ) 2552 CASE( 'oce only' ) ! C-grid ==> T 2551 2553 DO_2D( 0, 0, 0, 0 ) 2552 zotx1(ji,jj) = 0.5 * ( uu(ji,jj,1,Kmm) + uu(ji-1,jj ,1,Kmm) ) 2553 zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Kmm) + vv(ji , jj-1,1,Kmm) ) 2554 zotx1(ji,jj) = 0.5 * ( uu(ji,jj,1,Kmm) + uu(ji-1,jj ,1,Kmm) ) 2555 zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Kmm) + vv(ji , jj-1,1,Kmm) ) 2554 2556 END_2D 2555 CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T 2557 CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T 2556 2558 DO_2D( 0, 0, 0, 0 ) 2557 zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) 2558 zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) 2559 zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 2560 zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2559 zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) 2560 zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) 2561 zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 2562 zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2561 2563 END_2D 2562 CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) 2563 CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T 2564 CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) 2565 CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T 2564 2566 DO_2D( 0, 0, 0, 0 ) 2565 zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) & 2566 & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 2567 zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) & 2568 & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2567 zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) & 2568 & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 2569 zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) & 2570 & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2569 2571 END_2D 2570 2572 END SELECT 2571 CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp ) 2572 ! 2573 ! 2574 IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components 2575 ! ! Ocean component 2576 CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->e', ztmp1 ) ! 1st component 2577 CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->n', ztmp2 ) ! 2nd component 2578 zotx1(:,:) = ztmp1(:,:) ! overwrite the components 2579 zoty1(:,:) = ztmp2(:,:) 2580 IF( ssnd(jps_ivx1)%laction ) THEN ! Ice component 2581 CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component 2582 CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component 2583 zitx1(:,:) = ztmp1(:,:) ! overwrite the components 2584 zity1(:,:) = ztmp2(:,:) 2585 ENDIF 2586 ENDIF 2587 ! 2588 ! ! spherical coordinates to cartesian -> 2 components to 3 components 2589 ! IF( TRIM( sn_snd_crtw%clvref ) == 'cartesian' ) THEN 2590 ! ztmp1(:,:) = zotx1(:,:) ! ocean currents 2591 ! ztmp2(:,:) = zoty1(:,:) 2592 ! CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 ) 2593 ! ! 2594 ! IF( ssnd(jps_ivx1)%laction ) THEN ! ice velocities 2595 ! ztmp1(:,:) = zitx1(:,:) 2596 ! ztmp1(:,:) = zity1(:,:) 2597 ! CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 ) 2598 ! ENDIF 2599 ! ENDIF 2600 ! 2601 IF( ssnd(jps_ocxw)%laction ) CALL cpl_snd( jps_ocxw, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid 2602 IF( ssnd(jps_ocyw)%laction ) CALL cpl_snd( jps_ocyw, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid 2603 ! 2604 ENDIF 2605 ! 2606 IF( ssnd(jps_ficet)%laction ) THEN 2607 CALL cpl_snd( jps_ficet, isec, RESHAPE ( fr_i, (/jpi,jpj,1/) ), info ) 2608 ENDIF 2609 ! ! ------------------------- ! 2610 ! ! Water levels to waves ! 2611 ! ! ------------------------- ! 2612 IF( ssnd(jps_wlev)%laction ) THEN 2613 IF( ln_apr_dyn ) THEN 2614 IF( kt /= nit000 ) THEN 2615 ztmp1(:,:) = ssh(:,:,Kbb) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) 2616 ELSE 2617 ztmp1(:,:) = ssh(:,:,Kbb) 2618 ENDIF 2619 ELSE 2620 ztmp1(:,:) = ssh(:,:,Kmm) 2621 ENDIF 2622 CALL cpl_snd( jps_wlev , isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 2623 ENDIF 2573 CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp ) 2574 ! 2575 ! 2576 IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components 2577 ! ! Ocean component 2578 CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->e', ztmp1 ) ! 1st component 2579 CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->n', ztmp2 ) ! 2nd component 2580 zotx1(:,:) = ztmp1(:,:) ! overwrite the components 2581 zoty1(:,:) = ztmp2(:,:) 2582 IF( ssnd(jps_ivx1)%laction ) THEN ! Ice component 2583 CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component 2584 CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component 2585 zitx1(:,:) = ztmp1(:,:) ! overwrite the components 2586 zity1(:,:) = ztmp2(:,:) 2587 ENDIF 2588 ENDIF 2589 ! 2590 ! ! spherical coordinates to cartesian -> 2 components to 3 components 2591 ! IF( TRIM( sn_snd_crtw%clvref ) == 'cartesian' ) THEN 2592 ! ztmp1(:,:) = zotx1(:,:) ! ocean currents 2593 ! ztmp2(:,:) = zoty1(:,:) 2594 ! CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 ) 2595 ! ! 2596 ! IF( ssnd(jps_ivx1)%laction ) THEN ! ice velocities 2597 ! ztmp1(:,:) = zitx1(:,:) 2598 ! ztmp1(:,:) = zity1(:,:) 2599 ! CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 ) 2600 ! ENDIF 2601 ! ENDIF 2602 ! 2603 IF( ssnd(jps_ocxw)%laction ) CALL cpl_snd( jps_ocxw, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid 2604 IF( ssnd(jps_ocyw)%laction ) CALL cpl_snd( jps_ocyw, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid 2605 ! 2606 ENDIF 2607 ! 2608 IF( ssnd(jps_ficet)%laction ) THEN 2609 CALL cpl_snd( jps_ficet, isec, RESHAPE ( fr_i, (/jpi,jpj,1/) ), info ) 2610 ENDIF 2611 ! ! ------------------------- ! 2612 ! ! Water levels to waves ! 2613 ! ! ------------------------- ! 2614 IF( ssnd(jps_wlev)%laction ) THEN 2615 IF( ln_apr_dyn ) THEN 2616 IF( kt /= nit000 ) THEN 2617 ztmp1(:,:) = ssh(:,:,Kbb) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) 2618 ELSE 2619 ztmp1(:,:) = ssh(:,:,Kbb) 2620 ENDIF 2621 ELSE 2622 ztmp1(:,:) = ssh(:,:,Kmm) 2623 ENDIF 2624 CALL cpl_snd( jps_wlev , isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 2625 ENDIF 2624 2626 ! 2625 2627 ! Fields sent by OPA to SAS when doing OPA<->SAS coupling … … 2638 2640 CALL cpl_snd( jps_soce , isec, RESHAPE ( ts(:,:,1,jp_sal,Kmm), (/jpi,jpj,1/) ), info ) 2639 2641 ENDIF 2640 ! ! first T level thickness 2642 ! ! first T level thickness 2641 2643 IF( ssnd(jps_e3t1st )%laction ) THEN 2642 2644 CALL cpl_snd( jps_e3t1st, isec, RESHAPE ( e3t(:,:,1,Kmm) , (/jpi,jpj,1/) ), info ) … … 2660 2662 #if defined key_si3 2661 2663 ! ! ------------------------- ! 2662 ! ! Sea surface freezing temp ! 2664 ! ! Sea surface freezing temp ! 2663 2665 ! ! ------------------------- ! 2664 2666 ! needed by Met Office … … 2669 2671 ! 2670 2672 END SUBROUTINE sbc_cpl_snd 2671 2673 2672 2674 !!====================================================================== 2673 2675 END MODULE sbccpl -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/SBC/sbcmod.F90
r13546 r13655 27 27 USE closea ! closed seas 28 28 USE phycst ! physical constants 29 USE sbc_phy, ONLY : pp_cldf 29 30 USE sbc_oce ! Surface boundary condition: ocean fields 30 31 USE trc_oce ! shared ocean-passive tracers variables -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/tests/STATION_ASF/MY_SRC/diawri.F90
r12615 r13655 387 387 CALL iom_rstput( 0, 0, inum, 'sozotaux', utau ) ! i-wind stress 388 388 CALL iom_rstput( 0, 0, inum, 'sometauy', vtau ) ! j-wind stress 389 389 ! 390 CALL iom_close( inum ) 391 ! 390 392 #if defined key_si3 391 393 IF( nn_ice == 2 ) THEN ! condition needed in case agrif + ice-model but no-ice in child grid 394 CALL iom_open( TRIM(cdfile_name)//'_ice', inum, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) 392 395 CALL ice_wri_state( inum ) 393 ENDIF 396 CALL iom_close( inum ) 397 ENDIF 398 ! 394 399 #endif 395 !396 CALL iom_close( inum )397 !398 400 END SUBROUTINE dia_wri_state 399 401 -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/tests/STATION_ASF/MY_SRC/nemogcm.F90
r13286 r13655 30 30 USE step_c1d ! Time stepping loop for the 1D configuration 31 31 ! 32 USE prtctl ! Print control33 32 USE in_out_manager ! I/O manager 34 33 USE lib_mpp ! distributed memory computing … … 47 46 CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing 48 47 48 #if defined key_mpp_mpi 49 ! need MPI_Wtime 50 INCLUDE 'mpif.h' 51 #endif 52 49 53 !!---------------------------------------------------------------------- 50 54 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 51 !! $Id: nemogcm.F90 1 2489 2020-02-28 15:55:11Z davestorkey$55 !! $Id: nemogcm.F90 13286 2020-07-09 15:48:29Z smasson $ 52 56 !! Software governed by the CeCILL license (see ./LICENSE) 53 57 !!---------------------------------------------------------------------- … … 110 114 ! 111 115 #if defined key_iomput 112 116 CALL xios_finalize ! end mpp communications with xios 113 117 #else 114 118 IF( lk_mpp ) CALL mppstop ! end mpp communications … … 146 150 #if defined key_iomput 147 151 IF( Agrif_Root() ) THEN 148 152 CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm ) ! nemo local communicator given by xios 149 153 ENDIF 150 154 CALL mpp_start( ilocal_comm ) 151 155 #else 152 156 CALL mpp_start( ) 153 157 #endif 154 158 ! … … 163 167 IF( lwm ) CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 164 168 ! open reference and configuration namelist files 165 166 169 CALL load_nml( numnam_ref, 'namelist_ref', -1, lwm ) 170 CALL load_nml( numnam_cfg, 'namelist_cfg', -1, lwm ) 167 171 IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 168 172 ! open /dev/null file to be able to supress output write easily 169 173 IF( Agrif_Root() ) THEN 170 174 CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 171 175 #ifdef key_agrif 172 176 ELSE 173 numnul = Agrif_Parent(numnul) 174 #endif 175 ENDIF 176 ! 177 numnul = Agrif_Parent(numnul) 178 #endif 179 ENDIF 177 180 ! !--------------------! 178 181 ! ! Open listing units ! -> need sn_cfctl from namctl to define lwp … … 215 218 WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 216 219 WRITE(numout,*) 220 221 ! Print the working precision to ocean.output 222 IF (wp == dp) THEN 223 WRITE(numout,*) "Working precision = double-precision" 224 ELSE 225 WRITE(numout,*) "Working precision = single-precision" 226 ENDIF 227 WRITE(numout,*) 217 228 ! 218 229 WRITE(numout,cform_aaa) ! Flag AAAAAAA … … 229 240 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist' ) 230 241 READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) 231 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist' ) 242 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist' ) 232 243 ! 233 244 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file … … 260 271 IF( ln_timing ) CALL timing_start( 'nemo_init') 261 272 ! 262 263 273 CALL phy_cst ! Physical constants 274 CALL eos_init ! Equation of state 264 275 IF( lk_c1d ) CALL c1d_init ! 1D column configuration 265 276 CALL dom_init( Nbb, Nnn, Naa, "OPA") ! Domain 266 277 IF( sn_cfctl%l_prtctl ) & 267 278 & CALL prt_ctl_init ! Print control 268 ! 269 270 CALL istate_init( Nbb, Nnn, Naa ) ! ocean initial state (Dynamics and tracers) 271 272 ! ! external forcing 273 CALL sbc_init( Nbb, Nnn, Naa ) ! surface boundary conditions (including sea-ice) 279 280 CALL istate_init( Nbb, Nnn, Naa ) ! ocean initial state (Dynamics and tracers) 281 282 ! ! external forcing 283 CALL sbc_init( Nbb, Nnn, Naa ) ! surface boundary conditions (including sea-ice) 284 285 !#LB: 286 #if defined key_si3 287 IF(lwp) WRITE(numout,*) 'LOLO: nemo_init@nemogcm.F90: shape of fr_i ==>', SIZE(fr_i,1), SIZE(fr_i,2) 288 fr_i(:,:) = 0._wp 289 #endif 290 !#LB. 274 291 275 292 ! … … 302 319 WRITE(numout,*) ' sn_cfctl%l_prttrc = ', sn_cfctl%l_prttrc 303 320 WRITE(numout,*) ' sn_cfctl%l_oasout = ', sn_cfctl%l_oasout 304 WRITE(numout,*) ' sn_cfctl%procmin = ', sn_cfctl%procmin 305 WRITE(numout,*) ' sn_cfctl%procmax = ', sn_cfctl%procmax 306 WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr 307 WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr 321 WRITE(numout,*) ' sn_cfctl%procmin = ', sn_cfctl%procmin 322 WRITE(numout,*) ' sn_cfctl%procmax = ', sn_cfctl%procmax 323 WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr 324 WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr 308 325 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing 309 326 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl … … 366 383 !!---------------------------------------------------------------------- 367 384 ! 368 ierr = oce_alloc () ! ocean 385 ierr = oce_alloc () ! ocean 369 386 ierr = ierr + dia_wri_alloc() 370 387 ierr = ierr + dom_oce_alloc() ! ocean domain … … 375 392 END SUBROUTINE nemo_alloc 376 393 377 394 378 395 SUBROUTINE nemo_set_cfctl(sn_cfctl, setto ) 379 396 !!---------------------------------------------------------------------- … … 399 416 !!====================================================================== 400 417 END MODULE nemogcm 401 -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/tests/STATION_ASF/MY_SRC/sbcssm.F90
r12629 r13655 19 19 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 20 20 ! 21 #if defined key_si3 22 USE ice !#LB: we need to fill the "tm_su" array! 23 USE sbc_ice !#LB: we need to fill the "alb_ice" array! 24 #endif 25 ! 21 26 USE in_out_manager ! I/O manager 22 27 USE iom ! I/O library … … 48 53 INTEGER :: jf_e3t ! index of first T level thickness 49 54 INTEGER :: jf_frq ! index of fraction of qsr absorbed in the 1st T level 55 #if defined key_si3 56 INTEGER :: jf_ifr ! index of sea-ice concentration !#LB 57 INTEGER :: jf_tic ! index of sea-ice surface temperature !#LB 58 INTEGER :: jf_ial ! index of sea-ice surface albedo !#LB 59 #endif 50 60 51 61 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ssm_3d ! structure of input fields (file information, fields read) … … 54 64 !!---------------------------------------------------------------------- 55 65 !! NEMO/SAS 4.0 , NEMO Consortium (2018) 56 !! $Id: sbcssm.F90 1 2615 2020-03-26 15:18:49Z laurent$66 !! $Id: sbcssm.F90 13286 2020-07-09 15:48:29Z smasson $ 57 67 !! Software governed by the CeCILL license (see ./LICENSE) 58 68 !!---------------------------------------------------------------------- … … 73 83 ! (not needed for SAS but needed to keep a consistent interface in sbcmod.F90) 74 84 ! 75 INTEGER :: ji, jj 85 INTEGER :: ji, jj, jl ! dummy loop indices 76 86 REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation 77 87 REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation … … 84 94 IF( nfld_2d > 0 ) CALL fld_read( kt, 1, sf_ssm_2d ) !== read data at kt time step ==! 85 95 ! 86 IF( ln_3d_uve ) THEN 87 IF( .NOT. ln_linssh ) THEN 88 e3t_m(:,:) = sf_ssm_3d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor 89 ELSE 90 e3t_m(:,:) = e3t_0(:,:,1) ! vertical scale factor 91 ENDIF 92 ssu_m(:,:) = sf_ssm_3d(jf_usp)%fnow(:,:,1) * umask(:,:,1) ! u-velocity 93 ssv_m(:,:) = sf_ssm_3d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1) ! v-velocity 94 ELSE 95 IF( .NOT. ln_linssh ) THEN 96 e3t_m(:,:) = sf_ssm_2d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor 97 ELSE 98 e3t_m(:,:) = e3t_0(:,:,1) ! vertical scale factor 99 ENDIF 100 ssu_m(:,:) = sf_ssm_2d(jf_usp)%fnow(:,:,1) * umask(:,:,1) ! u-velocity 101 ssv_m(:,:) = sf_ssm_2d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1) ! v-velocity 102 ENDIF 103 ! 96 e3t_m(:,:) = e3t_0(:,:,1) ! vertical scale factor 97 ssu_m(:,:) = sf_ssm_2d(jf_usp)%fnow(:,:,1) * umask(:,:,1) ! u-velocity 98 ssv_m(:,:) = sf_ssm_2d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1) ! v-velocity 99 ! 100 !#LB: 101 #if defined key_si3 102 !IF(lwp) WRITE(numout,*) 'LOLO: sbc_ssm()@sbcssm.F90 => fill "tm_su" and other fields at kt =', kt 103 !IF(lwp) WRITE(numout,*) 'LOLO: sbc_ssm()@sbcssm.F90 => shape of at_i ==>', SIZE(at_i,1), SIZE(at_i,2) 104 at_i (:,:) = sf_ssm_2d(jf_ifr)%fnow(:,:,1) * tmask(:,:,1) ! sea-ice concentration [fraction] 105 tm_su(:,:) = sf_ssm_2d(jf_tic)%fnow(:,:,1) * tmask(:,:,1) ! sea-ice surface temperature, read in [K] !#LB 106 sst_m(:,:) = sf_ssm_2d(jf_ial)%fnow(:,:,1) * tmask(:,:,1) ! !!!sst_m AS TEMPORARY ARRAY !!! sea-ice albedo [fraction] 107 DO jl = 1, jpl 108 !IF(lwp) WRITE(numout,*) 'LOLO: sbc_ssm()@sbcssm.F90 => fill "t_su" for ice cat =', jl 109 a_i (:,:,jl) = at_i (:,:) 110 a_i_b (:,:,jl) = at_i (:,:) 111 t_su (:,:,jl) = tm_su(:,:) 112 alb_ice(:,:,jl) = sst_m(:,:) 113 END DO 114 !IF(lwp) WRITE(numout,*) '' 115 #endif 116 !#LB. 104 117 sst_m(:,:) = sf_ssm_2d(jf_tem)%fnow(:,:,1) * tmask(:,:,1) ! temperature 105 118 sss_m(:,:) = sf_ssm_2d(jf_sal)%fnow(:,:,1) * tmask(:,:,1) ! salinity 106 119 ssh_m(:,:) = sf_ssm_2d(jf_ssh)%fnow(:,:,1) * tmask(:,:,1) ! sea surface height 107 IF( ln_read_frq ) THEN 108 frq_m(:,:) = sf_ssm_2d(jf_frq)%fnow(:,:,1) * tmask(:,:,1) ! solar penetration 109 ELSE 110 frq_m(:,:) = 1._wp 111 ENDIF 120 frq_m(:,:) = 1._wp 112 121 ELSE 113 122 sss_m(:,:) = 35._wp ! =35. to obtain a physical value for the freezing point … … 116 125 ssv_m(:,:) = 0._wp 117 126 ssh_m(:,:) = 0._wp 118 IF( .NOT. ln_linssh ) e3t_m(:,:) = e3t_0(:,:,1) !clem: necessary at least for sas2D119 127 frq_m(:,:) = 1._wp ! - - 120 128 ssh (:,:,Kmm) = 0._wp ! - - … … 136 144 CALL prt_ctl(tab2d_1=ssv_m, clinfo1=' ssv_m - : ', mask1=vmask ) 137 145 CALL prt_ctl(tab2d_1=ssh_m, clinfo1=' ssh_m - : ', mask1=tmask ) 138 IF( .NOT.ln_linssh ) CALL prt_ctl(tab2d_1=ssh_m, clinfo1=' e3t_m - : ', mask1=tmask )139 IF( ln_read_frq ) CALL prt_ctl(tab2d_1=frq_m, clinfo1=' frq_m - : ', mask1=tmask )140 146 ENDIF 141 147 ! … … 146 152 CALL iom_put( 'sss_m', sss_m ) 147 153 CALL iom_put( 'ssh_m', ssh_m ) 148 IF( .NOT.ln_linssh ) CALL iom_put( 'e3t_m', e3t_m )149 IF( ln_read_frq ) CALL iom_put( 'frq_m', frq_m )150 154 ENDIF 151 155 ! … … 175 179 TYPE(FLD_N) :: sn_ssh, sn_e3t, sn_frq 176 180 !! 181 TYPE(FLD_N) :: sn_ifr, sn_tic, sn_ial ! #LB 182 !! 177 183 NAMELIST/namsbc_sas/ l_sasread, cn_dir, ln_3d_uve, ln_read_frq, & 178 & sn_tem, sn_sal, sn_usp, sn_vsp, sn_ssh, sn_e3t, sn_frq 184 & sn_tem, sn_sal, sn_usp, sn_vsp, sn_ssh, sn_e3t, sn_frq, & 185 & sn_ifr, sn_tic, sn_ial ! #LB 179 186 !!---------------------------------------------------------------------- 180 187 ! … … 196 203 WRITE(numout,*) ' Namelist namsbc_sas' 197 204 WRITE(numout,*) ' Initialisation using an input file l_sasread = ', l_sasread 198 WRITE(numout,*) ' Are we supplying a 3D u,v and e3 field ln_3d_uve = ', ln_3d_uve199 WRITE(numout,*) ' Are we reading frq (fraction of qsr absorbed in the 1st T level) ln_read_frq = ', ln_read_frq200 205 ENDIF 201 206 ! … … 218 223 IF( lwp ) WRITE(numout,*) ' ==>>> No freshwater budget adjustment needed with StandAlone Surface scheme' 219 224 nn_fwb = 0 225 ENDIF 226 IF( ln_closea ) THEN 227 IF( lwp ) WRITE(numout,*) ' ==>>> No closed seas adjustment needed with StandAlone Surface scheme' 228 ln_closea = .false. 220 229 ENDIF 221 230 … … 230 239 !! and the rest of the logic should still work 231 240 ! 232 jf_tem = 1 ; jf_ssh = 3 ! default 2D fields index 233 jf_sal = 2 ; jf_frq = 4 ! 234 ! 235 IF( ln_3d_uve ) THEN 236 jf_usp = 1 ; jf_vsp = 2 ; jf_e3t = 3 ! define 3D fields index 237 nfld_3d = 2 + COUNT( (/.NOT.ln_linssh/) ) ! number of 3D fields to read 238 nfld_2d = 3 + COUNT( (/ln_read_frq/) ) ! number of 2D fields to read 239 ELSE 240 jf_usp = 4 ; jf_e3t = 6 ! update 2D fields index 241 jf_vsp = 5 ; jf_frq = 6 + COUNT( (/.NOT.ln_linssh/) ) 242 ! 243 nfld_3d = 0 ! no 3D fields to read 244 nfld_2d = 5 + COUNT( (/.NOT.ln_linssh/) ) + COUNT( (/ln_read_frq/) ) ! number of 2D fields to read 245 ENDIF 241 !#LB: 242 jf_tem = 1 243 jf_sal = 2 244 jf_ssh = 3 245 jf_usp = 4 246 jf_vsp = 5 247 ! 248 nfld_3d = 0 249 nfld_2d = 5 250 ! 251 #if defined key_si3 252 jf_ifr = jf_vsp + 1 253 jf_tic = jf_vsp + 2 254 jf_ial = jf_vsp + 3 255 nfld_2d = nfld_2d + 3 256 257 !IF(lwp) WRITE(numout,*) 'LOLO: nfld_2d =', nfld_2d 258 !IF(lwp) WRITE(numout,*) 'LOLO: jf_tem =', jf_tem 259 !IF(lwp) WRITE(numout,*) 'LOLO: jf_sal =', jf_sal 260 !IF(lwp) WRITE(numout,*) 'LOLO: jf_ssh =', jf_ssh 261 !IF(lwp) WRITE(numout,*) 'LOLO: jf_usp =', jf_usp 262 !IF(lwp) WRITE(numout,*) 'LOLO: jf_vsp =', jf_vsp 263 !IF(lwp) WRITE(numout,*) 'LOLO: jf_ifr =', jf_ifr 264 !IF(lwp) WRITE(numout,*) 'LOLO: jf_tic =', jf_tic 265 !IF(lwp) WRITE(numout,*) 'LOLO: jf_ial =', jf_ial 266 !IF(lwp) WRITE(numout,*) '' 267 #endif 268 !#LB. 246 269 ! 247 270 IF( nfld_3d > 0 ) THEN … … 252 275 slf_3d(jf_usp) = sn_usp 253 276 slf_3d(jf_vsp) = sn_vsp 254 IF( .NOT.ln_linssh ) slf_3d(jf_e3t) = sn_e3t255 277 ENDIF 256 278 ! … … 261 283 ENDIF 262 284 slf_2d(jf_tem) = sn_tem ; slf_2d(jf_sal) = sn_sal ; slf_2d(jf_ssh) = sn_ssh 263 IF( ln_read_frq ) slf_2d(jf_frq) = sn_frq 264 IF( .NOT. ln_3d_uve ) THEN 265 slf_2d(jf_usp) = sn_usp ; slf_2d(jf_vsp) = sn_vsp 266 IF( .NOT.ln_linssh ) slf_2d(jf_e3t) = sn_e3t 267 ENDIF 285 slf_2d(jf_usp) = sn_usp ; slf_2d(jf_vsp) = sn_vsp 268 286 ENDIF 287 ! 288 #if defined key_si3 289 slf_2d(jf_ifr) = sn_ifr !#LB 290 slf_2d(jf_tic) = sn_tic !#LB 291 slf_2d(jf_ial) = sn_ial !#LB 292 #endif 269 293 ! 270 294 ierr1 = 0 ! default definition if slf_?d(ifpr)%ln_tint = .false. -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/tests/STATION_ASF/MY_SRC/step_c1d.F90
r13226 r13655 7 7 !! 3.0 ! 2008-04 (G. Madec) redo the adaptation to include SBC 8 8 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rewrite in preparation for new timestepping scheme 9 !! 4. 1 ! 2019-12(L. Brodeau) STATION_ASF test-case9 !! 4.x ! 2020-09 (L. Brodeau) STATION_ASF test-case 10 10 !!---------------------------------------------------------------------- 11 11 #if defined key_c1d … … 22 22 PRIVATE 23 23 24 PUBLIC stp_c1d ! called by nemogcm.F9024 PUBLIC stp_c1d ! called by nemogcm.F90 25 25 26 26 !!---------------------------------------------------------------------- 27 27 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 28 !! $Id: step_c1d.F90 1 2377 2020-02-12 14:39:06Z acc$28 !! $Id: step_c1d.F90 13237 2020-07-03 09:12:53Z smasson $ 29 29 !! Software governed by the CeCILL license (see ./LICENSE) 30 30 !!---------------------------------------------------------------------- … … 51 51 ! 52 52 INTEGER :: jk ! dummy loop indice 53 INTEGER :: indic ! error indicator if < 054 53 !! --------------------------------------------------------------------- 55 56 indic = 0 ! reset to no error condition57 54 IF( kstp == nit000 ) CALL iom_init( "nemo") ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 58 55 IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init) … … 63 60 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 64 61 CALL sbc ( kstp, Nbb, Nnn ) ! Sea Boundary Condition (including sea-ice) 65 62 ! #LB: ==> calls 'sbc_ssm()' ! 66 63 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 67 64 ! diagnostics and outputs … … 79 76 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 80 77 CALL stp_ctl( kstp, Nnn ) 81 82 78 IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file 83 79 IF( lrst_oce ) CALL rst_write( kstp, Nbb, Nnn ) ! write output ocean restart file -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/tests/STATION_ASF/MY_SRC/stpctl.F90
r13616 r13655 43 43 !!---------------------------------------------------------------------- 44 44 !! *** ROUTINE stp_ctl *** 45 !! 45 !! 46 46 !! ** Purpose : Control the run 47 47 !! … … 63 63 INTEGER , DIMENSION(4) :: iareasum, iareamin, iareamax 64 64 INTEGER , DIMENSION(3,3) :: iloc ! min/max loc indices 65 REAL(wp) :: zzz ! local real 65 REAL(wp) :: zzz ! local real 66 66 REAL(wp), DIMENSION(4) :: zmax, zmaxlocal 67 67 LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns, ll_0oce … … 72 72 ! 73 73 ll_wrtstp = ( MOD( kt-nit000, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) 74 ll_colruns = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1 74 ll_colruns = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1 75 75 ll_wrtruns = ( ll_colruns .OR. jpnij == 1 ) .AND. lwm 76 76 ! … … 98 98 istatus = NF90_ENDDEF(nrunid) 99 99 ENDIF 100 ! 100 ! 101 101 ENDIF 102 102 ! … … 158 158 IF( lwm .AND. kt /= nitend ) istatus = NF90_CLOSE(nrunid) 159 159 ! get global loc on the min/max 160 CALL mpp_maxloc( 'stpctl', taum(:,:) , llmsk, zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 160 CALL mpp_maxloc( 'stpctl', taum(:,:) , llmsk, zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 161 161 CALL mpp_maxloc( 'stpctl',ABS( qns(:,:) ), llmsk, zzz, iloc(1:2,2) ) 162 162 CALL mpp_minloc( 'stpctl',ABS( emp(:,:) ), llmsk, zzz, iloc(1:2,3) ) … … 194 194 CALL dia_wri_state( Kmm, 'output.abort' ) ! create an output.abort file 195 195 ! 196 IF( ll_colruns .or. jpnij == 1 ) THEN ! all processes synchronized -> use lwp to print in opened ocean.output files 197 IF(lwp) THEN ; CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 198 ELSE ; nstop = MAX(1, nstop) ! make sure nstop > 0 (automatically done when calling ctl_stop) 196 IF( ll_colruns .OR. jpnij == 1 ) THEN ! all processes synchronized -> use lwp to print in opened ocean.output files 197 IF(lwp) THEN 198 CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 199 ELSE 200 nstop = MAX(1, nstop) ! make sure nstop > 0 (automatically done when calling ctl_stop) 199 201 ENDIF 200 202 ELSE ! only mpi subdomains with errors are here -> STOP now … … 235 237 !!---------------------------------------------------------------------- 236 238 WRITE(clkt , '(i9)') kt 237 239 238 240 WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij ,wp))) + 1 ! how many digits to we need to write ? (we decide max = 9) 239 241 !!! WRITE(clsum, '(i'//clfmt//')') ksum ! this is creating a compilation error with AGRIF 240 242 cl4 = '(i'//clfmt//')' ; WRITE(clsum, cl4) ksum 241 243 WRITE(clfmt, '(i1)') INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1 ! how many digits to we need to write ? (we decide max = 9) 242 244 cl4 = '(i'//clfmt//')' ; WRITE(clmin, cl4) kmin-1 243 245 WRITE(clmax, cl4) kmax-1 244 246 ! 245 247 WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1 ! how many digits to we need to write jpiglo? (we decide max = 9) … … 257 259 ELSE 258 260 WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9) 259 261 !!! WRITE(clk, '(i'//clfmt//')') kloc(3) ! this is creating a compilation error with AGRIF 260 262 cl4 = '(i'//clfmt//')' ; WRITE(clk, cl4) kloc(3) ! this is ok with AGRIF 261 263 WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), TRIM(clk), TRIM(clsuff) -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/tests/STATION_ASF/MY_SRC/usrdef_hgr.F90
r13286 r13655 12 12 13 13 !!---------------------------------------------------------------------- 14 !! usr_def_hgr : initialize the horizontal mesh 14 !! usr_def_hgr : initialize the horizontal mesh 15 15 !!---------------------------------------------------------------------- 16 USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain 16 17 USE c1d , ONLY: rn_lon1d, rn_lat1d ! ocean lon/lat define by namelist 17 18 USE par_oce ! ocean space and time domain … … 21 22 USE in_out_manager ! I/O manager 22 23 USE lib_mpp ! MPP library 23 24 24 25 IMPLICIT NONE 25 26 PRIVATE … … 29 30 !!---------------------------------------------------------------------- 30 31 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 31 !! $Id: usrdef_hgr.F90 1 2489 2020-02-28 15:55:11Z davestorkey $32 !! $Id: usrdef_hgr.F90 13216 2020-07-02 09:25:49Z rblod $ 32 33 !! Software governed by the CeCILL license (see ./LICENSE) 33 34 !!---------------------------------------------------------------------- … … 48 49 !! 49 50 !! Here STATION_ASF configuration : 50 !! Rectangular 3x3 domain 51 !! Rectangular 3x3 domain 51 52 !! - Located at 150E-50N 52 !! - a constant horizontal resolution 53 !! - a constant horizontal resolution 53 54 !! 54 !! ** Action : - define longitude & latitude of t-, u-, v- and f-points (in degrees) 55 !! ** Action : - define longitude & latitude of t-, u-, v- and f-points (in degrees) 55 56 !! - define coriolis parameter at f-point if the domain in not on the sphere (on beta-plane) 56 57 !! - define i- & j-scale factors at t-, u-, v- and f-points (in meters) … … 63 64 REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1v, pe1f ! i-scale factors [m] 64 65 REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2u, pe2v, pe2f ! j-scale factors [m] 65 INTEGER , INTENT(out) :: ke1e2u_v ! =1 u- & v-surfaces computed here, =0 otherwise 66 INTEGER , INTENT(out) :: ke1e2u_v ! =1 u- & v-surfaces computed here, =0 otherwise 66 67 REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2] 67 68 ! … … 77 78 ! ! longitude 78 79 plamt(:,:) = rn_lon1d 79 plamu(:,:) = rn_lon1d 80 plamu(:,:) = rn_lon1d 80 81 plamv(:,:) = rn_lon1d 81 82 plamf(:,:) = rn_lon1d … … 93 94 pe1f(:,:) = 100. ; pe2f(:,:) = 100. 94 95 ! 95 ! ! NO reduction of grid size in some straits 96 ! ! NO reduction of grid size in some straits 96 97 ke1e2u_v = 0 ! ==>> u_ & v_surfaces will be computed in dom_ghr routine 97 98 pe1e2u(:,:) = 0._wp ! CAUTION: set to zero to avoid error with some compilers that … … 100 101 ! 101 102 ! !== Coriolis parameter ==! 102 zf0 = 2._wp * omega * SIN( rad * rn_lat1d ) 103 zf0 = 2._wp * omega * SIN( rad * rn_lat1d ) 103 104 pff_f(:,:) = zf0 104 pff_t(:,:) = zf0 105 pff_t(:,:) = zf0 105 106 kff = 1 ! indicate to skip computing Coriolis parameter afterward 106 107 ! -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/tests/STATION_ASF/MY_SRC/usrdef_nam.F90
r13286 r13655 13 13 !!---------------------------------------------------------------------- 14 14 !! usr_def_nam : read user defined namelist and set global domain size 15 !! usr_def_hgr : initialize the horizontal mesh 15 !! usr_def_hgr : initialize the horizontal mesh 16 16 !!---------------------------------------------------------------------- 17 USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain 17 18 USE par_oce ! ocean space and time domain 18 19 USE phycst ! physical constants … … 20 21 USE in_out_manager ! I/O manager 21 22 USE lib_mpp ! MPP library 22 23 23 24 IMPLICIT NONE 24 25 PRIVATE … … 31 32 !!---------------------------------------------------------------------- 32 33 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 33 !! $Id: usrdef_nam.F90 1 2377 2020-02-12 14:39:06Z acc $34 !! $Id: usrdef_nam.F90 13216 2020-07-02 09:25:49Z rblod $ 34 35 !! Software governed by the CeCILL license (see ./LICENSE) 35 36 !!---------------------------------------------------------------------- … … 39 40 !!---------------------------------------------------------------------- 40 41 !! *** ROUTINE dom_nam *** 41 !! 42 !! 42 43 !! ** Purpose : read user defined namelist and define the domain size 43 44 !! … … 50 51 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 51 52 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 52 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 53 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 53 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 54 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 54 55 ! 55 56 INTEGER :: ios ! Local integer -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/tests/STATION_ASF/MY_SRC/usrdef_zgr.F90
r12629 r13655 13 13 !!---------------------------------------------------------------------- 14 14 !! usr_def_zgr : user defined vertical coordinate system 15 !! zgr_z : reference 1D z-coordinate 15 !! zgr_z : reference 1D z-coordinate 16 16 !! zgr_top_bot: ocean top and bottom level indices 17 17 !! zgr_zco : 3D verticl coordinate in pure z-coordinate case … … 31 31 !!---------------------------------------------------------------------- 32 32 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 33 !! $Id: usrdef_zgr.F90 1 2377 2020-02-12 14:39:06Z acc$33 !! $Id: usrdef_zgr.F90 13226 2020-07-02 14:24:31Z orioltp $ 34 34 !! Software governed by the CeCILL license (see ./LICENSE) 35 35 !!---------------------------------------------------------------------- … … 54 54 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] 55 55 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] 56 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors 56 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors 57 57 INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level 58 58 !!---------------------------------------------------------------------- … … 85 85 pe3uw(:,:,1) = rn_dept1 ! LB??? 86 86 pe3vw(:,:,1) = rn_dept1 ! LB??? 87 87 88 88 !! 2nd level, technically useless (only for the sake of code stability) 89 89 pdept_1d(2) = 3._wp*rn_dept1
Note: See TracChangeset
for help on using the changeset viewer.