source: trunk/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk.F90 @ 8530

Last change on this file since 8530 was 8530, checked in by cbricaud, 3 years ago

fix ticket #1667 in trunk

File size: 58.2 KB
Line 
1MODULE sbcblk
2   !!======================================================================
3   !!                       ***  MODULE  sbcblk  ***
4   !! Ocean forcing:  momentum, heat and freshwater flux formulation
5   !!                         Aerodynamic Bulk Formulas
6   !!                        SUCCESSOR OF "sbcblk_core"
7   !!=====================================================================
8   !! History :  1.0  !  2004-08  (U. Schweckendiek)  Original CORE code
9   !!            2.0  !  2005-04  (L. Brodeau, A.M. Treguier)  improved CORE bulk and its user interface
10   !!            3.0  !  2006-06  (G. Madec)  sbc rewritting
11   !!             -   !  2006-12  (L. Brodeau)  Original code for turb_core
12   !!            3.2  !  2009-04  (B. Lemaire)  Introduce iom_put
13   !!            3.3  !  2010-10  (S. Masson)  add diurnal cycle
14   !!            3.4  !  2011-11  (C. Harris)  Fill arrays required by CICE
15   !!            3.7  !  2014-06  (L. Brodeau)  simplification and optimization of CORE bulk
16   !!            4.0  !  2016-06  (L. Brodeau)  sbcblk_core becomes sbcblk and is not restricted to the CORE algorithm anymore
17   !!                                          ==> based on AeroBulk (http://aerobulk.sourceforge.net/)
18   !!            4.0  !  2016-10  (G. Madec)  introduce a sbc_blk_init routine
19   !!----------------------------------------------------------------------
20
21   !!----------------------------------------------------------------------
22   !!   sbc_blk_init  : initialisation of the chosen bulk formulation as ocean surface boundary condition
23   !!   sbc_blk       : bulk formulation as ocean surface boundary condition
24   !!   blk_oce       : computes momentum, heat and freshwater fluxes over ocean
25   !!   blk_ice       : computes momentum, heat and freshwater fluxes over sea ice
26   !!   rho_air       : density of (moist) air (depends on T_air, q_air and SLP
27   !!   cp_air        : specific heat of (moist) air (depends spec. hum. q_air)
28   !!   q_sat         : saturation humidity as a function of SLP and temperature
29   !!   L_vap         : latent heat of vaporization of water as a function of temperature
30   !!----------------------------------------------------------------------
31   USE oce            ! ocean dynamics and tracers
32   USE dom_oce        ! ocean space and time domain
33   USE phycst         ! physical constants
34   USE fldread        ! read input fields
35   USE sbc_oce        ! Surface boundary condition: ocean fields
36   USE cyclone        ! Cyclone 10m wind form trac of cyclone centres
37   USE sbcdcy         ! surface boundary condition: diurnal cycle
38   USE sbcwave , ONLY :   cdn_wave ! wave module
39   USE sbc_ice        ! Surface boundary condition: ice fields
40   USE lib_fortran    ! to use key_nosignedzero
41#if defined key_lim3
42   USE ice     , ONLY :   u_ice, v_ice, jpl, pfrld, a_i_b, at_i_b
43   USE limthd_dh      ! for CALL lim_thd_snwblow
44#elif defined key_lim2
45   USE ice_2   , ONLY :   u_ice, v_ice
46   USE par_ice_2      ! LIM-2 parameters
47#endif
48   USE sbcblk_algo_ncar     ! => turb_ncar     : NCAR - CORE (Large & Yeager, 2009)
49   USE sbcblk_algo_coare    ! => turb_coare    : COAREv3.0 (Fairall et al. 2003)
50   USE sbcblk_algo_coare3p5 ! => turb_coare3p5 : COAREv3.5 (Edson et al. 2013)
51   USE sbcblk_algo_ecmwf    ! => turb_ecmwf    : ECMWF (IFS cycle 31)
52   !
53   USE iom            ! I/O manager library
54   USE in_out_manager ! I/O manager
55   USE lib_mpp        ! distribued memory computing library
56   USE wrk_nemo       ! work arrays
57   USE timing         ! Timing
58   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
59   USE prtctl         ! Print control
60
61   IMPLICIT NONE
62   PRIVATE
63
64   PUBLIC   sbc_blk_init  ! called in sbcmod
65   PUBLIC   sbc_blk       ! called in sbcmod
66#if defined key_lim2 || defined key_lim3
67   PUBLIC   blk_ice_tau   ! routine called in sbc_ice_lim module
68   PUBLIC   blk_ice_flx   ! routine called in sbc_ice_lim module
69#endif
70
71!!Lolo: should ultimately be moved in the module with all physical constants ?
72!!gm  : In principle, yes.
73   REAL(wp), PARAMETER ::   Cp_dry = 1005.0       !: Specic heat of dry air, constant pressure      [J/K/kg]
74   REAL(wp), PARAMETER ::   Cp_vap = 1860.0       !: Specic heat of water vapor, constant pressure  [J/K/kg]
75   REAL(wp), PARAMETER ::   R_dry = 287.05_wp     !: Specific gas constant for dry air              [J/K/kg]
76   REAL(wp), PARAMETER ::   R_vap = 461.495_wp    !: Specific gas constant for water vapor          [J/K/kg]
77   REAL(wp), PARAMETER ::   reps0 = R_dry/R_vap   !: ratio of gas constant for dry air and water vapor => ~ 0.622
78   REAL(wp), PARAMETER ::   rctv0 = R_vap/R_dry   !: for virtual temperature (== (1-eps)/eps) => ~ 0.608
79
80   INTEGER , PARAMETER ::   jpfld   =10           ! maximum number of files to read
81   INTEGER , PARAMETER ::   jp_wndi = 1           ! index of 10m wind velocity (i-component) (m/s)    at T-point
82   INTEGER , PARAMETER ::   jp_wndj = 2           ! index of 10m wind velocity (j-component) (m/s)    at T-point
83   INTEGER , PARAMETER ::   jp_tair = 3           ! index of 10m air temperature             (Kelvin)
84   INTEGER , PARAMETER ::   jp_humi = 4           ! index of specific humidity               ( % )
85   INTEGER , PARAMETER ::   jp_qsr  = 5           ! index of solar heat                      (W/m2)
86   INTEGER , PARAMETER ::   jp_qlw  = 6           ! index of Long wave                       (W/m2)
87   INTEGER , PARAMETER ::   jp_prec = 7           ! index of total precipitation (rain+snow) (Kg/m2/s)
88   INTEGER , PARAMETER ::   jp_snow = 8           ! index of snow (solid prcipitation)       (kg/m2/s)
89   INTEGER , PARAMETER ::   jp_slp  = 9           ! index of sea level pressure              (Pa)
90   INTEGER , PARAMETER ::   jp_tdif =10           ! index of tau diff associated to HF tau   (N/m2)   at T-point
91
92   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf   ! structure of input fields (file informations, fields read)
93
94   !                                             !!! Bulk parameters
95   REAL(wp), PARAMETER ::   cpa    = 1000.5         ! specific heat of air (only used for ice fluxes now...)
96   REAL(wp), PARAMETER ::   Ls     =    2.839e6     ! latent heat of sublimation
97   REAL(wp), PARAMETER ::   Stef   =    5.67e-8     ! Stefan Boltzmann constant
98   REAL(wp), PARAMETER ::   Cd_ice =    1.4e-3      ! iovi 1.63e-3     ! transfer coefficient over ice
99   REAL(wp), PARAMETER ::   albo   =    0.066       ! ocean albedo assumed to be constant
100   !
101   !                           !!* Namelist namsbc_blk : bulk parameters
102   LOGICAL  ::   ln_NCAR        ! "NCAR"      algorithm   (Large and Yeager 2008)
103   LOGICAL  ::   ln_COARE_3p0   ! "COARE 3.0" algorithm   (Fairall et al. 2003)
104   LOGICAL  ::   ln_COARE_3p5   ! "COARE 3.5" algorithm   (Edson et al. 2013)
105   LOGICAL  ::   ln_ECMWF       ! "ECMWF"     algorithm   (IFS cycle 31)
106   !
107   LOGICAL  ::   ln_taudif      ! logical flag to use the "mean of stress module - module of mean stress" data
108   REAL(wp) ::   rn_pfac        ! multiplication factor for precipitation
109   REAL(wp) ::   rn_efac        ! multiplication factor for evaporation (clem)
110   REAL(wp) ::   rn_vfac        ! multiplication factor for ice/ocean velocity in the calculation of wind stress (clem)
111   REAL(wp) ::   rn_zqt         ! z(q,t) : height of humidity and temperature measurements
112   REAL(wp) ::   rn_zu          ! z(u)   : height of wind measurements
113   LOGICAL  ::   ln_Cd_L12 = .FALSE. !  Modify the drag ice-atm and oce-atm depending on ice concentration (from Lupkes et al. JGR2012)
114   !
115   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   Cd_oce   ! air-ocean drag (clem)
116
117   INTEGER  ::   nblk           ! choice of the bulk algorithm
118   !                            ! associated indices:
119   INTEGER, PARAMETER ::   np_NCAR      = 1   ! "NCAR" algorithm        (Large and Yeager 2008)
120   INTEGER, PARAMETER ::   np_COARE_3p0 = 2   ! "COARE 3.0" algorithm   (Fairall et al. 2003)
121   INTEGER, PARAMETER ::   np_COARE_3p5 = 3   ! "COARE 3.5" algorithm   (Edson et al. 2013)
122   INTEGER, PARAMETER ::   np_ECMWF     = 4   ! "ECMWF" algorithm       (IFS cycle 31)
123
124   !! * Substitutions
125#  include "vectopt_loop_substitute.h90"
126   !!----------------------------------------------------------------------
127   !! NEMO/OPA 3.7 , NEMO-consortium (2014)
128   !! $Id: sbcblk.F90 6416 2016-04-01 12:22:17Z clem $
129   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
130   !!----------------------------------------------------------------------
131CONTAINS
132
133   INTEGER FUNCTION sbc_blk_alloc()
134      !!-------------------------------------------------------------------
135      !!             ***  ROUTINE sbc_blk_alloc ***
136      !!-------------------------------------------------------------------
137      ALLOCATE( Cd_oce(jpi,jpj) , STAT=sbc_blk_alloc )
138      !
139      IF( lk_mpp             )   CALL mpp_sum ( sbc_blk_alloc )
140      IF( sbc_blk_alloc /= 0 )   CALL ctl_warn('sbc_blk_alloc: failed to allocate arrays')
141   END FUNCTION sbc_blk_alloc
142
143   SUBROUTINE sbc_blk_init
144      !!---------------------------------------------------------------------
145      !!                    ***  ROUTINE sbc_blk_init  ***
146      !!
147      !! ** Purpose :   choose and initialize a bulk formulae formulation
148      !!
149      !! ** Method  :
150      !!
151      !!      C A U T I O N : never mask the surface stress fields
152      !!                      the stress is assumed to be in the (i,j) mesh referential
153      !!
154      !! ** Action  :   
155      !!
156      !!----------------------------------------------------------------------
157      INTEGER  ::   ifpr, jfld            ! dummy loop indice and argument
158      INTEGER  ::   ios, ierror, ioptio   ! Local integer
159      !!
160      CHARACTER(len=100)            ::   cn_dir                ! Root directory for location of atmospheric forcing files
161      TYPE(FLD_N), DIMENSION(jpfld) ::   slf_i                 ! array of namelist informations on the fields to read
162      TYPE(FLD_N) ::   sn_wndi, sn_wndj, sn_humi, sn_qsr       ! informations about the fields to be read
163      TYPE(FLD_N) ::   sn_qlw , sn_tair, sn_prec, sn_snow      !       "                        "
164      TYPE(FLD_N) ::   sn_slp , sn_tdif                        !       "                        "
165      NAMELIST/namsbc_blk/ sn_wndi, sn_wndj, sn_humi, sn_qsr, sn_qlw ,                &   ! input fields
166         &                 sn_tair, sn_prec, sn_snow, sn_slp, sn_tdif,                &
167         &                 ln_NCAR, ln_COARE_3p0, ln_COARE_3p5, ln_ECMWF,             &   ! bulk algorithm
168         &                 cn_dir , ln_taudif, rn_zqt, rn_zu,                         & 
169         &                 rn_pfac, rn_efac, rn_vfac, ln_Cd_L12
170      !!---------------------------------------------------------------------
171      !
172      !                                      ! allocate sbc_blk_core array
173      IF( sbc_blk_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_blk : unable to allocate standard arrays' )
174      !
175      !                             !** read bulk namelist 
176      REWIND( numnam_ref )                !* Namelist namsbc_blk in reference namelist : bulk parameters
177      READ  ( numnam_ref, namsbc_blk, IOSTAT = ios, ERR = 901)
178901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_blk in reference namelist', lwp )
179      !
180      REWIND( numnam_cfg )                !* Namelist namsbc_blk in configuration namelist : bulk parameters
181      READ  ( numnam_cfg, namsbc_blk, IOSTAT = ios, ERR = 902 )
182902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_blk in configuration namelist', lwp )
183      !
184      IF(lwm) WRITE( numond, namsbc_blk )
185      !
186      !                             !** initialization of the chosen bulk formulae (+ check)
187      !                                   !* select the bulk chosen in the namelist and check the choice
188      ;                                                        ioptio = 0
189      IF( ln_NCAR      ) THEN   ;   nblk =  np_NCAR        ;   ioptio = ioptio + 1   ;   ENDIF
190      IF( ln_COARE_3p0 ) THEN   ;   nblk =  np_COARE_3p0   ;   ioptio = ioptio + 1   ;   ENDIF
191      IF( ln_COARE_3p5 ) THEN   ;   nblk =  np_COARE_3p5   ;   ioptio = ioptio + 1   ;   ENDIF
192      IF( ln_ECMWF     ) THEN   ;   nblk =  np_ECMWF       ;   ioptio = ioptio + 1   ;   ENDIF
193      !
194      IF( ioptio /= 1 )   CALL ctl_stop( 'sbc_blk_init: Choose one and only one bulk algorithm' )
195      !
196      IF( ln_dm2dc ) THEN                 !* check: diurnal cycle on Qsr
197         IF( sn_qsr%nfreqh /= 24 )   CALL ctl_stop( 'sbc_blk_init: ln_dm2dc=T only with daily short-wave input' )
198         IF( sn_qsr%ln_tint ) THEN
199            CALL ctl_warn( 'sbc_blk_init: ln_dm2dc=T daily qsr time interpolation done by sbcdcy module',   &
200               &           '              ==> We force time interpolation = .false. for qsr' )
201            sn_qsr%ln_tint = .false.
202         ENDIF
203      ENDIF
204      !                                   !* set the bulk structure
205      !                                      !- store namelist information in an array
206      slf_i(jp_wndi) = sn_wndi   ;   slf_i(jp_wndj) = sn_wndj
207      slf_i(jp_qsr ) = sn_qsr    ;   slf_i(jp_qlw ) = sn_qlw
208      slf_i(jp_tair) = sn_tair   ;   slf_i(jp_humi) = sn_humi
209      slf_i(jp_prec) = sn_prec   ;   slf_i(jp_snow) = sn_snow
210      slf_i(jp_slp)  = sn_slp    ;   slf_i(jp_tdif) = sn_tdif
211      !
212      lhftau = ln_taudif                     !- add an extra field if HF stress is used
213      jfld = jpfld - COUNT( (/.NOT.lhftau/) )
214      !
215      !                                      !- allocate the bulk structure
216      ALLOCATE( sf(jfld), STAT=ierror )
217      IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_blk_init: unable to allocate sf structure' )
218      DO ifpr= 1, jfld
219         ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) )
220         IF( slf_i(ifpr)%ln_tint )   ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) )
221
222           IF( slf_i(ifpr)%nfreqh .GT. 0._wp .AND. MOD( 3600._wp * slf_i(ifpr)%nfreqh , REAL(nn_fsbc, wp) * rdt) .NE. 0._wp  )   &
223            &  CALL ctl_warn( 'sbcmod time step rdt * nn_fsbc is NOT a submultiple of atmospheric forcing frequency' )
224
225      END DO
226      !                                      !- fill the bulk structure with namelist informations
227      CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_init', 'surface boundary condition -- bulk formulae', 'namsbc_blk' )
228      !
229      IF ( ln_wave ) THEN
230      !Activated wave module but neither drag nor stokes drift activated
231         IF ( .NOT.(ln_cdgw .OR. ln_sdw .OR. ln_tauoc .OR. ln_stcor ) )   THEN
232            CALL ctl_warn( 'Ask for wave coupling but ln_cdgw=F, ln_sdw=F, ln_tauoc=F, ln_stcor=F')
233      !drag coefficient read from wave model definable only with mfs bulk formulae and core
234         ELSEIF (ln_cdgw .AND. .NOT. ln_NCAR )       THEN       
235             CALL ctl_stop( 'drag coefficient read from wave model definable only with mfs bulk formulae and core')
236         ELSEIF (ln_stcor .AND. .NOT. ln_sdw)                             THEN
237             CALL ctl_stop( 'Stokes-Coriolis term calculated only if activated Stokes Drift ln_sdw=T')
238         ENDIF
239      ELSE
240      IF ( ln_cdgw .OR. ln_sdw .OR. ln_tauoc .OR. ln_stcor )                & 
241         &   CALL ctl_stop( 'Not Activated Wave Module (ln_wave=F) but asked coupling ',    &
242         &                  'with drag coefficient (ln_cdgw =T) '  ,                        &
243         &                  'or Stokes Drift (ln_sdw=T) ' ,                                 &
244         &                  'or ocean stress modification due to waves (ln_tauoc=T) ',      & 
245         &                  'or Stokes-Coriolis term (ln_stcori=T)'  )
246      ENDIF 
247      !
248      !           
249      IF(lwp) THEN                     !** Control print
250         !
251         WRITE(numout,*)                  !* namelist
252         WRITE(numout,*) '   Namelist namsbc_blk (other than data information):'
253         WRITE(numout,*) '      "NCAR"      algorithm   (Large and Yeager 2008)     ln_NCAR      = ', ln_NCAR
254         WRITE(numout,*) '      "COARE 3.0" algorithm   (Fairall et al. 2003)       ln_COARE_3p0 = ', ln_COARE_3p0
255         WRITE(numout,*) '      "COARE 3.5" algorithm   (Edson et al. 2013)         ln_COARE_3p5 = ', ln_COARE_3p0
256         WRITE(numout,*) '      "ECMWF"     algorithm   (IFS cycle 31)              ln_ECMWF     = ', ln_ECMWF
257         WRITE(numout,*) '      add High freq.contribution to the stress module     ln_taudif    = ', ln_taudif
258         WRITE(numout,*) '      Air temperature and humidity reference height (m)   rn_zqt       = ', rn_zqt
259         WRITE(numout,*) '      Wind vector reference height (m)                    rn_zu        = ', rn_zu
260         WRITE(numout,*) '      factor applied on precipitation (total & snow)      rn_pfac      = ', rn_pfac
261         WRITE(numout,*) '      factor applied on evaporation                       rn_efac      = ', rn_efac
262         WRITE(numout,*) '      factor applied on ocean/ice velocity                rn_vfac      = ', rn_vfac
263         WRITE(numout,*) '         (form absolute (=0) to relative winds(=1))'
264         !
265         WRITE(numout,*)
266         SELECT CASE( nblk )              !* Print the choice of bulk algorithm
267         CASE( np_NCAR      )   ;   WRITE(numout,*) '      ===>>   "NCAR" algorithm        (Large and Yeager 2008)'
268         CASE( np_COARE_3p0 )   ;   WRITE(numout,*) '      ===>>   "COARE 3.0" algorithm   (Fairall et al. 2003)'
269         CASE( np_COARE_3p5 )   ;   WRITE(numout,*) '      ===>>   "COARE 3.5" algorithm   (Edson et al. 2013)'
270         CASE( np_ECMWF     )   ;   WRITE(numout,*) '      ===>>   "ECMWF" algorithm       (IFS cycle 31)'
271         END SELECT
272         !
273      ENDIF
274      !
275   END SUBROUTINE sbc_blk_init
276
277
278   SUBROUTINE sbc_blk( kt )
279      !!---------------------------------------------------------------------
280      !!                    ***  ROUTINE sbc_blk  ***
281      !!
282      !! ** Purpose :   provide at each time step the surface ocean fluxes
283      !!      (momentum, heat, freshwater and runoff)
284      !!
285      !! ** Method  : (1) READ each fluxes in NetCDF files:
286      !!      the 10m wind velocity (i-component) (m/s)    at T-point
287      !!      the 10m wind velocity (j-component) (m/s)    at T-point
288      !!      the 10m or 2m specific humidity     ( % )
289      !!      the solar heat                      (W/m2)
290      !!      the Long wave                       (W/m2)
291      !!      the 10m or 2m air temperature       (Kelvin)
292      !!      the total precipitation (rain+snow) (Kg/m2/s)
293      !!      the snow (solid prcipitation)       (kg/m2/s)
294      !!      the tau diff associated to HF tau   (N/m2)   at T-point   (ln_taudif=T)
295      !!              (2) CALL blk_oce
296      !!
297      !!      C A U T I O N : never mask the surface stress fields
298      !!                      the stress is assumed to be in the (i,j) mesh referential
299      !!
300      !! ** Action  :   defined at each time-step at the air-sea interface
301      !!              - utau, vtau  i- and j-component of the wind stress
302      !!              - taum        wind stress module at T-point
303      !!              - wndm        wind speed  module at T-point over free ocean or leads in presence of sea-ice
304      !!              - qns, qsr    non-solar and solar heat fluxes
305      !!              - emp         upward mass flux (evapo. - precip.)
306      !!              - sfx         salt flux due to freezing/melting (non-zero only if ice is present)
307      !!                            (set in limsbc(_2).F90)
308      !!
309      !! ** References :   Large & Yeager, 2004 / Large & Yeager, 2008
310      !!                   Brodeau et al. Ocean Modelling 2010
311      !!----------------------------------------------------------------------
312      INTEGER, INTENT(in) ::   kt   ! ocean time step
313      !!---------------------------------------------------------------------
314      !
315      CALL fld_read( kt, nn_fsbc, sf )             ! input fields provided at the current time-step
316      !
317      !                                            ! compute the surface ocean fluxes using bulk formulea
318      IF( MOD( kt - 1, nn_fsbc ) == 0 )   CALL blk_oce( kt, sf, sst_m, ssu_m, ssv_m )
319
320#if defined key_cice
321      IF( MOD( kt - 1, nn_fsbc ) == 0 )   THEN
322         qlw_ice(:,:,1)   = sf(jp_qlw )%fnow(:,:,1)
323         IF( ln_dm2dc ) THEN ; qsr_ice(:,:,1) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) )
324         ELSE                ; qsr_ice(:,:,1) =          sf(jp_qsr)%fnow(:,:,1) 
325         ENDIF
326         tatm_ice(:,:)    = sf(jp_tair)%fnow(:,:,1)
327         qatm_ice(:,:)    = sf(jp_humi)%fnow(:,:,1)
328         tprecip(:,:)     = sf(jp_prec)%fnow(:,:,1) * rn_pfac
329         sprecip(:,:)     = sf(jp_snow)%fnow(:,:,1) * rn_pfac
330         wndi_ice(:,:)    = sf(jp_wndi)%fnow(:,:,1)
331         wndj_ice(:,:)    = sf(jp_wndj)%fnow(:,:,1)
332      ENDIF
333#endif
334      !
335   END SUBROUTINE sbc_blk
336
337
338   SUBROUTINE blk_oce( kt, sf, pst, pu, pv )
339      !!---------------------------------------------------------------------
340      !!                     ***  ROUTINE blk_oce  ***
341      !!
342      !! ** Purpose :   provide the momentum, heat and freshwater fluxes at
343      !!      the ocean surface at each time step
344      !!
345      !! ** Method  :   bulk formulea for the ocean using atmospheric
346      !!      fields read in sbc_read
347      !!
348      !! ** Outputs : - utau    : i-component of the stress at U-point  (N/m2)
349      !!              - vtau    : j-component of the stress at V-point  (N/m2)
350      !!              - taum    : Wind stress module at T-point         (N/m2)
351      !!              - wndm    : Wind speed module at T-point          (m/s)
352      !!              - qsr     : Solar heat flux over the ocean        (W/m2)
353      !!              - qns     : Non Solar heat flux over the ocean    (W/m2)
354      !!              - emp     : evaporation minus precipitation       (kg/m2/s)
355      !!
356      !!  ** Nota  :   sf has to be a dummy argument for AGRIF on NEC
357      !!---------------------------------------------------------------------
358      INTEGER  , INTENT(in   )                 ::   kt    ! time step index
359      TYPE(fld), INTENT(inout), DIMENSION(:)   ::   sf    ! input data
360      REAL(wp) , INTENT(in)   , DIMENSION(:,:) ::   pst   ! surface temperature                      [Celcius]
361      REAL(wp) , INTENT(in)   , DIMENSION(:,:) ::   pu    ! surface current at U-point (i-component) [m/s]
362      REAL(wp) , INTENT(in)   , DIMENSION(:,:) ::   pv    ! surface current at V-point (j-component) [m/s]
363      !
364      INTEGER  ::   ji, jj               ! dummy loop indices
365      REAL(wp) ::   zztmp                ! local variable
366      REAL(wp), DIMENSION(:,:), POINTER ::   zwnd_i, zwnd_j    ! wind speed components at T-point
367      REAL(wp), DIMENSION(:,:), POINTER ::   zsq               ! specific humidity at pst
368      REAL(wp), DIMENSION(:,:), POINTER ::   zqlw, zqsb        ! long wave and sensible heat fluxes
369      REAL(wp), DIMENSION(:,:), POINTER ::   zqla, zevap       ! latent heat fluxes and evaporation
370      REAL(wp), DIMENSION(:,:), POINTER ::   Cd                ! transfer coefficient for momentum      (tau)
371      REAL(wp), DIMENSION(:,:), POINTER ::   Ch                ! transfer coefficient for sensible heat (Q_sens)
372      REAL(wp), DIMENSION(:,:), POINTER ::   Ce                ! tansfert coefficient for evaporation   (Q_lat)
373      REAL(wp), DIMENSION(:,:), POINTER ::   zst               ! surface temperature in Kelvin
374      REAL(wp), DIMENSION(:,:), POINTER ::   zt_zu             ! air temperature at wind speed height
375      REAL(wp), DIMENSION(:,:), POINTER ::   zq_zu             ! air spec. hum.  at wind speed height
376      REAL(wp), DIMENSION(:,:), POINTER ::   zU_zu             ! bulk wind speed at height zu  [m/s]
377      REAL(wp), DIMENSION(:,:), POINTER ::   ztpot             ! potential temperature of air at z=rn_zqt [K]
378      REAL(wp), DIMENSION(:,:), POINTER ::   zrhoa             ! density of air   [kg/m^3]
379      !!---------------------------------------------------------------------
380      !
381      IF( nn_timing == 1 )  CALL timing_start('blk_oce')
382      !
383      CALL wrk_alloc( jpi,jpj,   zwnd_i, zwnd_j, zsq, zqlw, zqsb, zqla, zevap )
384      CALL wrk_alloc( jpi,jpj,   Cd, Ch, Ce, zst, zt_zu, zq_zu )
385      CALL wrk_alloc( jpi,jpj,   zU_zu, ztpot, zrhoa )
386      !
387
388      ! local scalars ( place there for vector optimisation purposes)
389      zst(:,:) = pst(:,:) + rt0      ! convert SST from Celcius to Kelvin (and set minimum value far above 0 K)
390
391      ! ----------------------------------------------------------------------------- !
392      !      0   Wind components and module at T-point relative to the moving ocean   !
393      ! ----------------------------------------------------------------------------- !
394
395      ! ... components ( U10m - U_oce ) at T-point (unmasked)
396!!gm    move zwnd_i (_j) set to zero  inside the key_cyclone ???
397      zwnd_i(:,:) = 0._wp
398      zwnd_j(:,:) = 0._wp
399#if defined key_cyclone
400      CALL wnd_cyc( kt, zwnd_i, zwnd_j )    ! add analytical tropical cyclone (Vincent et al. JGR 2012)
401      DO jj = 2, jpjm1
402         DO ji = fs_2, fs_jpim1   ! vect. opt.
403            sf(jp_wndi)%fnow(ji,jj,1) = sf(jp_wndi)%fnow(ji,jj,1) + zwnd_i(ji,jj)
404            sf(jp_wndj)%fnow(ji,jj,1) = sf(jp_wndj)%fnow(ji,jj,1) + zwnd_j(ji,jj)
405         END DO
406      END DO
407#endif
408      DO jj = 2, jpjm1
409         DO ji = fs_2, fs_jpim1   ! vect. opt.
410            zwnd_i(ji,jj) = (  sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pu(ji-1,jj  ) + pu(ji,jj) )  )
411            zwnd_j(ji,jj) = (  sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pv(ji  ,jj-1) + pv(ji,jj) )  )
412         END DO
413      END DO
414      CALL lbc_lnk( zwnd_i(:,:) , 'T', -1. )
415      CALL lbc_lnk( zwnd_j(:,:) , 'T', -1. )
416      ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked)
417      wndm(:,:) = SQRT(  zwnd_i(:,:) * zwnd_i(:,:)   &
418         &             + zwnd_j(:,:) * zwnd_j(:,:)  ) * tmask(:,:,1)
419
420      ! ----------------------------------------------------------------------------- !
421      !      I   Radiative FLUXES                                                     !
422      ! ----------------------------------------------------------------------------- !
423
424      ! ocean albedo assumed to be constant + modify now Qsr to include the diurnal cycle                    ! Short Wave
425      zztmp = 1. - albo
426      IF( ln_dm2dc ) THEN   ;   qsr(:,:) = zztmp * sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1)
427      ELSE                  ;   qsr(:,:) = zztmp *          sf(jp_qsr)%fnow(:,:,1)   * tmask(:,:,1)
428      ENDIF
429
430      zqlw(:,:) = (  sf(jp_qlw)%fnow(:,:,1) - Stef * zst(:,:)*zst(:,:)*zst(:,:)*zst(:,:)  ) * tmask(:,:,1)   ! Long  Wave
431
432
433
434      ! ----------------------------------------------------------------------------- !
435      !     II    Turbulent FLUXES                                                    !
436      ! ----------------------------------------------------------------------------- !
437
438      ! ... specific humidity at SST and IST tmask(
439      zsq(:,:) = 0.98 * q_sat( zst(:,:), sf(jp_slp)%fnow(:,:,1) )
440      !!
441      !! Estimate of potential temperature at z=rn_zqt, based on adiabatic lapse-rate
442      !!    (see Josey, Gulev & Yu, 2013) / doi=10.1016/B978-0-12-391851-2.00005-2
443      !!    (since reanalysis products provide T at z, not theta !)
444      ztpot = sf(jp_tair)%fnow(:,:,1) + gamma_moist( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1) ) * rn_zqt
445
446      SELECT CASE( nblk )        !==  transfer coefficients  ==!   Cd, Ch, Ce at T-point
447      !
448      CASE( np_NCAR      )   ;   CALL turb_ncar    ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm,   &  ! NCAR-COREv2
449         &                                               Cd, Ch, Ce, zt_zu, zq_zu, zU_zu )
450      CASE( np_COARE_3p0 )   ;   CALL turb_coare   ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm,   &  ! COARE v3.0
451         &                                               Cd, Ch, Ce, zt_zu, zq_zu, zU_zu )
452      CASE( np_COARE_3p5 )   ;   CALL turb_coare3p5( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm,   &  ! COARE v3.5
453         &                                               Cd, Ch, Ce, zt_zu, zq_zu, zU_zu )
454      CASE( np_ECMWF     )   ;   CALL turb_ecmwf   ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm,   &  ! ECMWF
455         &                                               Cd, Ch, Ce, zt_zu, zq_zu, zU_zu )
456      CASE DEFAULT
457         CALL ctl_stop( 'STOP', 'sbc_oce: non-existing bulk formula selected' )
458      END SELECT
459
460      !                          ! Compute true air density :
461      IF( ABS(rn_zu - rn_zqt) > 0.01 ) THEN     ! At zu: (probably useless to remove zrho*grav*rn_zu from SLP...)
462         zrhoa(:,:) = rho_air( zt_zu(:,:)             , zq_zu(:,:)             , sf(jp_slp)%fnow(:,:,1) )
463      ELSE                                      ! At zt:
464         zrhoa(:,:) = rho_air( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1) )
465      END IF
466
467      Cd_oce(:,:) = Cd(:,:)  ! record value of pure ocean-atm. drag (clem)
468
469      DO jj = 1, jpj             ! tau module, i and j component
470         DO ji = 1, jpi
471            zztmp = zrhoa(ji,jj)  * zU_zu(ji,jj) * Cd(ji,jj)   ! using bulk wind speed
472            taum  (ji,jj) = zztmp * wndm  (ji,jj)
473            zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj)
474            zwnd_j(ji,jj) = zztmp * zwnd_j(ji,jj)
475         END DO
476      END DO
477
478      !                          ! add the HF tau contribution to the wind stress module
479      IF( lhftau )   taum(:,:) = taum(:,:) + sf(jp_tdif)%fnow(:,:,1)
480
481      CALL iom_put( "taum_oce", taum )   ! output wind stress module
482
483      ! ... utau, vtau at U- and V_points, resp.
484      !     Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines
485      !     Note the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves
486      DO jj = 1, jpjm1
487         DO ji = 1, fs_jpim1
488            utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( zwnd_i(ji,jj) + zwnd_i(ji+1,jj  ) ) &
489               &          * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1))
490            vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( zwnd_j(ji,jj) + zwnd_j(ji  ,jj+1) ) &
491               &          * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1))
492         END DO
493      END DO
494      CALL lbc_lnk( utau(:,:), 'U', -1. )
495      CALL lbc_lnk( vtau(:,:), 'V', -1. )
496
497
498      !  Turbulent fluxes over ocean
499      ! -----------------------------
500
501      ! zqla used as temporary array, for rho*U (common term of bulk formulae):
502      zqla(:,:) = zrhoa(:,:) * zU_zu(:,:)
503
504      IF( ABS( rn_zu - rn_zqt) < 0.01_wp ) THEN
505         !! q_air and t_air are given at 10m (wind reference height)
506         zevap(:,:) = rn_efac*MAX( 0._wp,             zqla(:,:)*Ce(:,:)*(zsq(:,:) - sf(jp_humi)%fnow(:,:,1)) ) ! Evaporation, using bulk wind speed
507         zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch(:,:)*(zst(:,:) - ztpot(:,:)             )   ! Sensible Heat, using bulk wind speed
508      ELSE
509         !! q_air and t_air are not given at 10m (wind reference height)
510         ! Values of temp. and hum. adjusted to height of wind during bulk algorithm iteration must be used!!!
511         zevap(:,:) = rn_efac*MAX( 0._wp,             zqla(:,:)*Ce(:,:)*(zsq(:,:) - zq_zu(:,:) ) ) ! Evaporation ! using bulk wind speed
512         zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch(:,:)*(zst(:,:) - zt_zu(:,:) )   ! Sensible Heat ! using bulk wind speed
513      ENDIF
514
515      zqla(:,:) = L_vap(zst(:,:)) * zevap(:,:)     ! Latent Heat flux
516
517
518      IF(ln_ctl) THEN
519         CALL prt_ctl( tab2d_1=zqla  , clinfo1=' blk_oce: zqla   : ', tab2d_2=Ce , clinfo2=' Ce  : ' )
520         CALL prt_ctl( tab2d_1=zqsb  , clinfo1=' blk_oce: zqsb   : ', tab2d_2=Ch , clinfo2=' Ch  : ' )
521         CALL prt_ctl( tab2d_1=zqlw  , clinfo1=' blk_oce: zqlw   : ', tab2d_2=qsr, clinfo2=' qsr : ' )
522         CALL prt_ctl( tab2d_1=zsq   , clinfo1=' blk_oce: zsq    : ', tab2d_2=zst, clinfo2=' zst : ' )
523         CALL prt_ctl( tab2d_1=utau  , clinfo1=' blk_oce: utau   : ', mask1=umask,   &
524            &          tab2d_2=vtau  , clinfo2=           ' vtau : ', mask2=vmask )
525         CALL prt_ctl( tab2d_1=wndm  , clinfo1=' blk_oce: wndm   : ')
526         CALL prt_ctl( tab2d_1=zst   , clinfo1=' blk_oce: zst    : ')
527      ENDIF
528
529      ! ----------------------------------------------------------------------------- !
530      !     III    Total FLUXES                                                       !
531      ! ----------------------------------------------------------------------------- !
532      !
533      emp (:,:) = (  zevap(:,:)                                          &   ! mass flux (evap. - precip.)
534         &         - sf(jp_prec)%fnow(:,:,1) * rn_pfac  ) * tmask(:,:,1)
535      !
536      qns(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:)                                &   ! Downward Non Solar
537         &     - sf(jp_snow)%fnow(:,:,1) * rn_pfac * lfus                         &   ! remove latent melting heat for solid precip
538         &     - zevap(:,:) * pst(:,:) * rcp                                      &   ! remove evap heat content at SST
539         &     + ( sf(jp_prec)%fnow(:,:,1) - sf(jp_snow)%fnow(:,:,1) ) * rn_pfac  &   ! add liquid precip heat content at Tair
540         &     * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp                          &
541         &     + sf(jp_snow)%fnow(:,:,1) * rn_pfac                                &   ! add solid  precip heat content at min(Tair,Tsnow)
542         &     * ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1)
543      !
544#if defined key_lim3
545      qns_oce(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:)                                ! non solar without emp (only needed by LIM3)
546      qsr_oce(:,:) = qsr(:,:)
547#endif
548      !
549      IF ( nn_ice == 0 ) THEN
550         CALL iom_put( "qlw_oce" ,   zqlw )                 ! output downward longwave heat over the ocean
551         CALL iom_put( "qsb_oce" , - zqsb )                 ! output downward sensible heat over the ocean
552         CALL iom_put( "qla_oce" , - zqla )                 ! output downward latent   heat over the ocean
553         CALL iom_put( "qemp_oce",   qns-zqlw+zqsb+zqla )   ! output downward heat content of E-P over the ocean
554         CALL iom_put( "qns_oce" ,   qns  )                 ! output downward non solar heat over the ocean
555         CALL iom_put( "qsr_oce" ,   qsr  )                 ! output downward solar heat over the ocean
556         CALL iom_put( "qt_oce"  ,   qns+qsr )              ! output total downward heat over the ocean
557         tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac   ! output total precipitation [kg/m2/s]
558         sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac   ! output solid precipitation [kg/m2/s]
559         CALL iom_put( 'snowpre', sprecip * 86400. )        ! Snow
560         CALL iom_put( 'precip' , tprecip * 86400. )        ! Total precipitation
561      ENDIF
562      !
563      IF(ln_ctl) THEN
564         CALL prt_ctl(tab2d_1=zqsb , clinfo1=' blk_oce: zqsb   : ', tab2d_2=zqlw , clinfo2=' zqlw  : ')
565         CALL prt_ctl(tab2d_1=zqla , clinfo1=' blk_oce: zqla   : ', tab2d_2=qsr  , clinfo2=' qsr   : ')
566         CALL prt_ctl(tab2d_1=pst  , clinfo1=' blk_oce: pst    : ', tab2d_2=emp  , clinfo2=' emp   : ')
567         CALL prt_ctl(tab2d_1=utau , clinfo1=' blk_oce: utau   : ', mask1=umask,   &
568            &         tab2d_2=vtau , clinfo2=              ' vtau  : ' , mask2=vmask )
569      ENDIF
570      !
571      CALL wrk_dealloc( jpi,jpj,   zwnd_i, zwnd_j, zsq, zqlw, zqsb, zqla, zevap )
572      CALL wrk_dealloc( jpi,jpj,   Cd, Ch, Ce, zst, zt_zu, zq_zu )
573      CALL wrk_dealloc( jpi,jpj,   zU_zu, ztpot, zrhoa )
574      !
575      IF( nn_timing == 1 )  CALL timing_stop('blk_oce')
576      !
577   END SUBROUTINE blk_oce
578
579#if defined key_lim2 || defined key_lim3
580
581   SUBROUTINE blk_ice_tau
582      !!---------------------------------------------------------------------
583      !!                     ***  ROUTINE blk_ice_tau  ***
584      !!
585      !! ** Purpose :   provide the surface boundary condition over sea-ice
586      !!
587      !! ** Method  :   compute momentum using bulk formulation
588      !!                formulea, ice variables and read atmospheric fields.
589      !!                NB: ice drag coefficient is assumed to be a constant
590      !!---------------------------------------------------------------------
591      INTEGER  ::   ji, jj    ! dummy loop indices
592      !
593      REAL(wp), DIMENSION(:,:)  , POINTER :: zrhoa
594      !
595      REAL(wp) ::   zwnorm_f, zwndi_f , zwndj_f               ! relative wind module and components at F-point
596      REAL(wp) ::             zwndi_t , zwndj_t               ! relative wind components at T-point
597      REAL(wp), DIMENSION(:,:), POINTER ::   Cd               ! transfer coefficient for momentum      (tau)
598      !!---------------------------------------------------------------------
599      !
600      IF( nn_timing == 1 )  CALL timing_start('blk_ice_tau')
601      !
602      CALL wrk_alloc( jpi,jpj, zrhoa )
603      CALL wrk_alloc( jpi,jpj, Cd )
604
605      Cd(:,:) = Cd_ice
606
607      ! Make ice-atm. drag dependent on ice concentration (see Lupkes et al. 2012) (clem)
608#if defined key_lim3
609      IF( ln_Cd_L12 ) THEN
610         CALL Cdn10_Lupkes2012( Cd ) ! calculate new drag from Lupkes(2012) equations
611      ENDIF
612#endif
613
614      ! local scalars ( place there for vector optimisation purposes)
615      ! Computing density of air! Way denser that 1.2 over sea-ice !!!
616      !!
617      zrhoa (:,:) =  rho_air(sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1))
618
619      !!gm brutal....
620      utau_ice  (:,:) = 0._wp
621      vtau_ice  (:,:) = 0._wp
622      wndm_ice  (:,:) = 0._wp
623      !!gm end
624
625      ! ----------------------------------------------------------------------------- !
626      !    Wind components and module relative to the moving ocean ( U10m - U_ice )   !
627      ! ----------------------------------------------------------------------------- !
628      SELECT CASE( cp_ice_msh )
629      CASE( 'I' )                  ! B-grid ice dynamics :   I-point (i.e. F-point with sea-ice indexation)
630         !                           and scalar wind at T-point ( = | U10m - U_ice | ) (masked)
631         DO jj = 2, jpjm1
632            DO ji = 2, jpim1   ! B grid : NO vector opt
633               ! ... scalar wind at I-point (fld being at T-point)
634               zwndi_f = 0.25 * (  sf(jp_wndi)%fnow(ji-1,jj  ,1) + sf(jp_wndi)%fnow(ji  ,jj  ,1)   &
635                  &              + sf(jp_wndi)%fnow(ji-1,jj-1,1) + sf(jp_wndi)%fnow(ji  ,jj-1,1)  ) - rn_vfac * u_ice(ji,jj)
636               zwndj_f = 0.25 * (  sf(jp_wndj)%fnow(ji-1,jj  ,1) + sf(jp_wndj)%fnow(ji  ,jj  ,1)   &
637                  &              + sf(jp_wndj)%fnow(ji-1,jj-1,1) + sf(jp_wndj)%fnow(ji  ,jj-1,1)  ) - rn_vfac * v_ice(ji,jj)
638               zwnorm_f = zrhoa(ji,jj) * Cd(ji,jj) * SQRT( zwndi_f * zwndi_f + zwndj_f * zwndj_f )
639               ! ... ice stress at I-point
640               utau_ice(ji,jj) = zwnorm_f * zwndi_f
641               vtau_ice(ji,jj) = zwnorm_f * zwndj_f
642               ! ... scalar wind at T-point (fld being at T-point)
643               zwndi_t = sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.25 * (  u_ice(ji,jj+1) + u_ice(ji+1,jj+1)   &
644                  &                                                    + u_ice(ji,jj  ) + u_ice(ji+1,jj  )  )
645               zwndj_t = sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.25 * (  v_ice(ji,jj+1) + v_ice(ji+1,jj+1)   &
646                  &                                                    + v_ice(ji,jj  ) + v_ice(ji+1,jj  )  )
647               wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1)
648            END DO
649         END DO
650         CALL lbc_lnk( utau_ice, 'I', -1. )
651         CALL lbc_lnk( vtau_ice, 'I', -1. )
652         CALL lbc_lnk( wndm_ice, 'T',  1. )
653         !
654      CASE( 'C' )                  ! C-grid ice dynamics :   U & V-points (same as ocean)
655         DO jj = 2, jpj
656            DO ji = fs_2, jpi   ! vect. opt.
657               zwndi_t = (  sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( u_ice(ji-1,jj  ) + u_ice(ji,jj) )  )
658               zwndj_t = (  sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( v_ice(ji  ,jj-1) + v_ice(ji,jj) )  )
659               wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1)
660            END DO
661         END DO
662         DO jj = 2, jpjm1
663            DO ji = fs_2, fs_jpim1   ! vect. opt.
664               utau_ice(ji,jj) = 0.5 * zrhoa(ji,jj) * Cd(ji,jj) * ( wndm_ice(ji+1,jj  ) + wndm_ice(ji,jj) )                          &
665                  &          * ( 0.5 * (sf(jp_wndi)%fnow(ji+1,jj,1) + sf(jp_wndi)%fnow(ji,jj,1) ) - rn_vfac * u_ice(ji,jj) )
666               vtau_ice(ji,jj) = 0.5 * zrhoa(ji,jj) * Cd(ji,jj) * ( wndm_ice(ji,jj+1  ) + wndm_ice(ji,jj) )                          &
667                  &          * ( 0.5 * (sf(jp_wndj)%fnow(ji,jj+1,1) + sf(jp_wndj)%fnow(ji,jj,1) ) - rn_vfac * v_ice(ji,jj) )
668            END DO
669         END DO
670         CALL lbc_lnk( utau_ice, 'U', -1. )
671         CALL lbc_lnk( vtau_ice, 'V', -1. )
672         CALL lbc_lnk( wndm_ice, 'T',  1. )
673         !
674      END SELECT
675
676      IF(ln_ctl) THEN
677         CALL prt_ctl(tab2d_1=utau_ice  , clinfo1=' blk_ice: utau_ice : ', tab2d_2=vtau_ice  , clinfo2=' vtau_ice : ')
678         CALL prt_ctl(tab2d_1=wndm_ice  , clinfo1=' blk_ice: wndm_ice : ')
679      ENDIF
680
681      IF( nn_timing == 1 )  CALL timing_stop('blk_ice_tau')
682
683   END SUBROUTINE blk_ice_tau
684
685
686   SUBROUTINE blk_ice_flx( ptsu, palb )
687      !!---------------------------------------------------------------------
688      !!                     ***  ROUTINE blk_ice_flx  ***
689      !!
690      !! ** Purpose :   provide the surface boundary condition over sea-ice
691      !!
692      !! ** Method  :   compute heat and freshwater exchanged
693      !!                between atmosphere and sea-ice using bulk formulation
694      !!                formulea, ice variables and read atmmospheric fields.
695      !!
696      !! caution : the net upward water flux has with mm/day unit
697      !!---------------------------------------------------------------------
698      REAL(wp), DIMENSION(:,:,:), INTENT(in)  ::   ptsu   ! sea ice surface temperature
699      REAL(wp), DIMENSION(:,:,:), INTENT(in)  ::   palb   ! ice albedo (all skies)
700      !!
701      INTEGER  ::   ji, jj, jl               ! dummy loop indices
702      REAL(wp) ::   zst2, zst3               ! local variable
703      REAL(wp) ::   zcoef_dqlw, zcoef_dqla   !   -      -
704      REAL(wp) ::   zztmp, z1_lsub           !   -      -
705      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qlw         ! long wave heat flux over ice
706      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qsb         ! sensible  heat flux over ice
707      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqlw        ! long wave heat sensitivity over ice
708      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqsb        ! sensible  heat sensitivity over ice
709      REAL(wp), DIMENSION(:,:)  , POINTER ::   zevap, zsnw   ! evaporation and snw distribution after wind blowing (LIM3)
710      REAL(wp), DIMENSION(:,:)  , POINTER ::   zrhoa
711      REAL(wp), DIMENSION(:,:)  , POINTER ::   Cd            ! transfer coefficient for momentum      (tau)
712      !!---------------------------------------------------------------------
713      !
714      IF( nn_timing == 1 )  CALL timing_start('blk_ice_flx')
715      !
716      CALL wrk_alloc( jpi,jpj,jpl,   z_qlw, z_qsb, z_dqlw, z_dqsb )
717      CALL wrk_alloc( jpi,jpj,       zrhoa)
718      CALL wrk_alloc( jpi,jpj, Cd )
719
720      Cd(:,:) = Cd_ice
721
722      ! Make ice-atm. drag dependent on ice concentration (see Lupkes et al.  2012) (clem)
723#if defined key_lim3
724      IF( ln_Cd_L12 ) THEN
725         CALL Cdn10_Lupkes2012( Cd ) ! calculate new drag from Lupkes(2012) equations
726      ENDIF
727#endif
728
729      !
730      ! local scalars ( place there for vector optimisation purposes)
731      zcoef_dqlw   = 4.0 * 0.95 * Stef
732      zcoef_dqla   = -Ls * 11637800. * (-5897.8)
733      !
734      zrhoa(:,:) = rho_air( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1) )
735      !
736      zztmp = 1. / ( 1. - albo )
737      !                                     ! ========================== !
738      DO jl = 1, jpl                        !  Loop over ice categories  !
739         !                                  ! ========================== !
740         DO jj = 1 , jpj
741            DO ji = 1, jpi
742               ! ----------------------------!
743               !      I   Radiative FLUXES   !
744               ! ----------------------------!
745               zst2 = ptsu(ji,jj,jl) * ptsu(ji,jj,jl)
746               zst3 = ptsu(ji,jj,jl) * zst2
747               ! Short Wave (sw)
748               qsr_ice(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj)
749               ! Long  Wave (lw)
750               z_qlw(ji,jj,jl) = 0.95 * ( sf(jp_qlw)%fnow(ji,jj,1) - Stef * ptsu(ji,jj,jl) * zst3 ) * tmask(ji,jj,1)
751               ! lw sensitivity
752               z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3
753
754               ! ----------------------------!
755               !     II    Turbulent FLUXES  !
756               ! ----------------------------!
757
758               ! ... turbulent heat fluxes
759               ! Sensible Heat
760               z_qsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * Cd(ji,jj) * wndm_ice(ji,jj) * ( ptsu(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1) )
761               ! Latent Heat
762               qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, zrhoa(ji,jj) * Ls  * Cd(ji,jj) * wndm_ice(ji,jj)   &
763                  &                         * (  11637800. * EXP( -5897.8 / ptsu(ji,jj,jl) ) / zrhoa(ji,jj) - sf(jp_humi)%fnow(ji,jj,1)  ) )
764               ! Latent heat sensitivity for ice (Dqla/Dt)
765               IF( qla_ice(ji,jj,jl) > 0._wp ) THEN
766                  dqla_ice(ji,jj,jl) = rn_efac * zcoef_dqla * Cd(ji,jj) * wndm_ice(ji,jj) / ( zst2 ) * EXP( -5897.8 / ptsu(ji,jj,jl) )
767               ELSE
768                  dqla_ice(ji,jj,jl) = 0._wp
769               ENDIF
770
771               ! Sensible heat sensitivity (Dqsb_ice/Dtn_ice)
772               z_dqsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * Cd(ji,jj) * wndm_ice(ji,jj)
773
774               ! ----------------------------!
775               !     III    Total FLUXES     !
776               ! ----------------------------!
777               ! Downward Non Solar flux
778               qns_ice (ji,jj,jl) =     z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - qla_ice (ji,jj,jl)
779               ! Total non solar heat flux sensitivity for ice
780               dqns_ice(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + dqla_ice(ji,jj,jl) )
781            END DO
782            !
783         END DO
784         !
785      END DO
786      !
787      tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac      ! total precipitation [kg/m2/s]
788      sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac      ! solid precipitation [kg/m2/s]
789      CALL iom_put( 'snowpre', sprecip * 86400. )                  ! Snow precipitation
790      CALL iom_put( 'precip' , tprecip * 86400. )                  ! Total precipitation
791
792#if defined  key_lim3
793      CALL wrk_alloc( jpi,jpj,   zevap, zsnw )
794
795      ! --- evaporation --- !
796      z1_lsub = 1._wp / Lsub
797      evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_lsub    ! sublimation
798      devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_lsub    ! d(sublimation)/dT
799      zevap    (:,:)   = rn_efac * ( emp(:,:) + tprecip(:,:) )  ! evaporation over ocean
800
801      ! --- evaporation minus precipitation --- !
802      zsnw(:,:) = 0._wp
803      CALL lim_thd_snwblow( pfrld, zsnw )  ! snow distribution over ice after wind blowing
804      emp_oce(:,:) = pfrld(:,:) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw )
805      emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw
806      emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:)
807
808      ! --- heat flux associated with emp --- !
809      qemp_oce(:,:) = - pfrld(:,:) * zevap(:,:) * sst_m(:,:) * rcp                               & ! evap at sst
810         &          + ( tprecip(:,:) - sprecip(:,:) ) * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp  & ! liquid precip at Tair
811         &          +   sprecip(:,:) * ( 1._wp - zsnw ) *                                        & ! solid precip at min(Tair,Tsnow)
812         &              ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus )
813      qemp_ice(:,:) =   sprecip(:,:) * zsnw *                                                    & ! solid precip (only)
814         &              ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus )
815
816      ! --- total solar and non solar fluxes --- !
817      qns_tot(:,:) = pfrld(:,:) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) + qemp_ice(:,:) + qemp_oce(:,:)
818      qsr_tot(:,:) = pfrld(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 )
819
820      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- !
821      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus )
822
823      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) ---
824      DO jl = 1, jpl
825         qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) )
826                                   ! But we do not have Tice => consider it at 0degC => evap=0
827      END DO
828
829      CALL wrk_dealloc( jpi,jpj,   zevap, zsnw )
830#endif
831
832      !--------------------------------------------------------------------
833      ! FRACTIONs of net shortwave radiation which is not absorbed in the
834      ! thin surface layer and penetrates inside the ice cover
835      ! ( Maykut and Untersteiner, 1971 ; Ebert and Curry, 1993 )
836      !
837      fr1_i0(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice )
838      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice )
839      !
840      !
841      IF(ln_ctl) THEN
842         CALL prt_ctl(tab3d_1=qla_ice , clinfo1=' blk_ice: qla_ice  : ', tab3d_2=z_qsb   , clinfo2=' z_qsb    : ', kdim=jpl)
843         CALL prt_ctl(tab3d_1=z_qlw   , clinfo1=' blk_ice: z_qlw    : ', tab3d_2=dqla_ice, clinfo2=' dqla_ice : ', kdim=jpl)
844         CALL prt_ctl(tab3d_1=z_dqsb  , clinfo1=' blk_ice: z_dqsb   : ', tab3d_2=z_dqlw  , clinfo2=' z_dqlw   : ', kdim=jpl)
845         CALL prt_ctl(tab3d_1=dqns_ice, clinfo1=' blk_ice: dqns_ice : ', tab3d_2=qsr_ice , clinfo2=' qsr_ice  : ', kdim=jpl)
846         CALL prt_ctl(tab3d_1=ptsu    , clinfo1=' blk_ice: ptsu     : ', tab3d_2=qns_ice , clinfo2=' qns_ice  : ', kdim=jpl)
847         CALL prt_ctl(tab2d_1=tprecip , clinfo1=' blk_ice: tprecip  : ', tab2d_2=sprecip , clinfo2=' sprecip  : ')
848      ENDIF
849
850      CALL wrk_dealloc( jpi,jpj,jpl,   z_qlw, z_qsb, z_dqlw, z_dqsb )
851      CALL wrk_dealloc( jpi,jpj,       zrhoa )
852      CALL wrk_dealloc( jpi,jpj, Cd )
853      !
854      IF( nn_timing == 1 )  CALL timing_stop('blk_ice_flx')
855
856   END SUBROUTINE blk_ice_flx
857   
858#endif
859
860   FUNCTION rho_air( ptak, pqa, pslp )
861      !!-------------------------------------------------------------------------------
862      !!                           ***  FUNCTION rho_air  ***
863      !!
864      !! ** Purpose : compute density of (moist) air using the eq. of state of the atmosphere
865      !!
866      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
867      !!-------------------------------------------------------------------------------
868      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   ptak      ! air temperature             [K]
869      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pqa       ! air specific humidity   [kg/kg]
870      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pslp      ! pressure in                [Pa]
871      REAL(wp), DIMENSION(jpi,jpj)             ::   rho_air   ! density of moist air   [kg/m^3]
872      !!-------------------------------------------------------------------------------
873      !
874      rho_air = pslp / (  R_dry*ptak * ( 1._wp + rctv0*pqa )  )
875      !
876   END FUNCTION rho_air
877
878
879   FUNCTION cp_air( pqa )
880      !!-------------------------------------------------------------------------------
881      !!                           ***  FUNCTION cp_air  ***
882      !!
883      !! ** Purpose : Compute specific heat (Cp) of moist air
884      !!
885      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
886      !!-------------------------------------------------------------------------------
887      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pqa      ! air specific humidity         [kg/kg]
888      REAL(wp), DIMENSION(jpi,jpj)             ::   cp_air   ! specific heat of moist air   [J/K/kg]
889      !!-------------------------------------------------------------------------------
890      !
891      Cp_air = Cp_dry + Cp_vap * pqa
892      !
893   END FUNCTION cp_air
894
895
896   FUNCTION q_sat( ptak, pslp )
897      !!----------------------------------------------------------------------------------
898      !!                           ***  FUNCTION q_sat  ***
899      !!
900      !! ** Purpose : Specific humidity at saturation in [kg/kg]
901      !!              Based on accurate estimate of "e_sat"
902      !!              aka saturation water vapor (Goff, 1957)
903      !!
904      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
905      !!----------------------------------------------------------------------------------
906      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   ptak    ! air temperature                       [K]
907      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pslp    ! sea level atmospheric pressure       [Pa]
908      REAL(wp), DIMENSION(jpi,jpj)             ::   q_sat   ! Specific humidity at saturation   [kg/kg]
909      !
910      INTEGER  ::   ji, jj         ! dummy loop indices
911      REAL(wp) ::   ze_sat, ztmp   ! local scalar
912      !!----------------------------------------------------------------------------------
913      !
914      DO jj = 1, jpj
915         DO ji = 1, jpi
916            !
917            ztmp = rt0 / ptak(ji,jj)
918            !
919            ! Vapour pressure at saturation [hPa] : WMO, (Goff, 1957)
920            ze_sat = 10.**( 10.79574*(1. - ztmp) - 5.028*LOG10(ptak(ji,jj)/rt0)        &
921               &    + 1.50475*10.**(-4)*(1. - 10.**(-8.2969*(ptak(ji,jj)/rt0 - 1.)) )  &
922               &    + 0.42873*10.**(-3)*(10.**(4.76955*(1. - ztmp)) - 1.) + 0.78614  )
923               !
924            q_sat(ji,jj) = reps0 * ze_sat/( 0.01_wp*pslp(ji,jj) - (1._wp - reps0)*ze_sat )   ! 0.01 because SLP is in [Pa]
925            !
926         END DO
927      END DO
928      !
929   END FUNCTION q_sat
930
931
932   FUNCTION gamma_moist( ptak, pqa )
933      !!----------------------------------------------------------------------------------
934      !!                           ***  FUNCTION gamma_moist  ***
935      !!
936      !! ** Purpose : Compute the moist adiabatic lapse-rate.
937      !!     => http://glossary.ametsoc.org/wiki/Moist-adiabatic_lapse_rate
938      !!     => http://www.geog.ucsb.edu/~joel/g266_s10/lecture_notes/chapt03/oh10_3_01/oh10_3_01.html
939      !!
940      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
941      !!----------------------------------------------------------------------------------
942      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   ptak          ! air temperature       [K]
943      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pqa           ! specific humidity [kg/kg]
944      REAL(wp), DIMENSION(jpi,jpj)             ::   gamma_moist   ! moist adiabatic lapse-rate
945      !
946      INTEGER  ::   ji, jj         ! dummy loop indices
947      REAL(wp) :: zrv, ziRT        ! local scalar
948      !!----------------------------------------------------------------------------------
949      !
950      DO jj = 1, jpj
951         DO ji = 1, jpi
952            zrv = pqa(ji,jj) / (1. - pqa(ji,jj))
953            ziRT = 1. / (R_dry*ptak(ji,jj))    ! 1/RT
954            gamma_moist(ji,jj) = grav * ( 1. + cevap*zrv*ziRT ) / ( Cp_dry + cevap*cevap*zrv*reps0*ziRT/ptak(ji,jj) )
955         END DO
956      END DO
957      !
958   END FUNCTION gamma_moist
959
960
961   FUNCTION L_vap( psst )
962      !!---------------------------------------------------------------------------------
963      !!                           ***  FUNCTION L_vap  ***
964      !!
965      !! ** Purpose : Compute the latent heat of vaporization of water from temperature
966      !!
967      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
968      !!----------------------------------------------------------------------------------
969      REAL(wp), DIMENSION(jpi,jpj)             ::   L_vap   ! latent heat of vaporization   [J/kg]
970      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   psst   ! water temperature                [K]
971      !!----------------------------------------------------------------------------------
972      !
973      L_vap = (  2.501 - 0.00237 * ( psst(:,:) - rt0)  ) * 1.e6
974      !
975   END FUNCTION L_vap
976
977
978#if defined key_lim3
979   SUBROUTINE Cdn10_Lupkes2012( Cd )
980      !!----------------------------------------------------------------------
981      !!                      ***  ROUTINE  Cdn10_Lupkes2012  ***
982      !!
983      !! ** Purpose :    Recompute the ice-atm drag at 10m height to make
984      !!                 it dependent on edges at leads, melt ponds and flows.
985      !!                 After some approximations, this can be resumed to a dependency
986      !!                 on ice concentration.
987      !!               
988      !! ** Method :     The parameterization is taken from Lupkes et al. (2012) eq.(50)
989      !!                 with the highest level of approximation: level4, eq.(59)
990      !!                 The generic drag over a cell partly covered by ice can be re-written as follows:
991      !!
992      !!                 Cd = Cdw * (1-A) + Cdi * A + Ce * (1-A)**(nu+1/(10*beta)) * A**mu
993      !!
994      !!                    Ce = 2.23e-3       , as suggested by Lupkes (eq. 59)
995      !!                    nu = mu = beta = 1 , as suggested by Lupkes (eq. 59)
996      !!                    A is the concentration of ice minus melt ponds (if any)
997      !!
998      !!                 This new drag has a parabolic shape (as a function of A) starting at
999      !!                 Cdw(say 1.5e-3) for A=0, reaching 1.97e-3 for A~0.5
1000      !!                 and going down to Cdi(say 1.4e-3) for A=1
1001      !!
1002      !!                 It is theoretically applicable to all ice conditions (not only MIZ)
1003      !!                 => see Lupkes et al (2013)
1004      !!
1005      !! ** References : Lupkes et al. JGR 2012 (theory)
1006      !!                 Lupkes et al. GRL 2013 (application to GCM)
1007      !!
1008      !!----------------------------------------------------------------------
1009      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   Cd
1010      REAL(wp), PARAMETER ::   zCe   = 2.23e-03_wp
1011      REAL(wp), PARAMETER ::   znu   = 1._wp
1012      REAL(wp), PARAMETER ::   zmu   = 1._wp
1013      REAL(wp), PARAMETER ::   zbeta = 1._wp
1014      REAL(wp)            ::   zcoef
1015      !!----------------------------------------------------------------------
1016      zcoef = znu + 1._wp / ( 10._wp * zbeta )
1017
1018      ! generic drag over a cell partly covered by ice
1019      !!Cd(:,:) = Cd_oce(:,:) * ( 1._wp - at_i_b(:,:) ) +  &                        ! pure ocean drag
1020      !!   &      Cd_ice      *           at_i_b(:,:)   +  &                        ! pure ice drag
1021      !!   &      zCe         * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**zmu   ! change due to sea-ice morphology
1022
1023      ! ice-atm drag
1024      Cd(:,:) = Cd_ice +  &                                                         ! pure ice drag
1025         &      zCe    * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**(zmu-1._wp)  ! change due to sea-ice morphology
1026     
1027   END SUBROUTINE Cdn10_Lupkes2012
1028#endif
1029   
1030
1031   !!======================================================================
1032END MODULE sbcblk
Note: See TracBrowser for help on using the repository browser.