New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

sbccpl.F90 in branches/UKMO/dev_r5518_med_test/NEMOGCM/NEMO/OPA_SRC/SBC – NEMO

Context Navigation

source: branches/UKMO/dev_r5518_med_test/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90 @ 6200

Last change on this file since 6200 was 6200, checked in by frrh, 8 years ago
Merge in branches/UKMO/dev_r5518_coupling_GSI7_GSI8_landice@5797 and MY medusa interface, resolve conflicts in sbccpl and, mysteriously in sbcice_cice.F90 which frankly should not occur since I am doing nothing in here!
File size: 134.2 KB

Line
1	MODULE sbccpl
2	!!======================================================================
3	!! * MODULE sbccpl *
4	!! Surface Boundary Condition : momentum, heat and freshwater fluxes in coupled mode
5	!!======================================================================
6	!! History : 2.0 ! 2007-06 (R. Redler, N. Keenlyside, W. Park) Original code split into flxmod & taumod
7	!! 3.0 ! 2008-02 (G. Madec, C Talandier) surface module
8	!! 3.1 ! 2009_02 (G. Madec, S. Masson, E. Maisonave, A. Caubel) generic coupled interface
9	!! 3.4 ! 2011_11 (C. Harris) more flexibility + multi-category fields
10	!!----------------------------------------------------------------------
11	!!----------------------------------------------------------------------
12	!! namsbc_cpl : coupled formulation namlist
13	!! sbc_cpl_init : initialisation of the coupled exchanges
14	!! sbc_cpl_rcv : receive fields from the atmosphere over the ocean (ocean only)
15	!! receive stress from the atmosphere over the ocean (ocean-ice case)
16	!! sbc_cpl_ice_tau : receive stress from the atmosphere over ice
17	!! sbc_cpl_ice_flx : receive fluxes from the atmosphere over ice
18	!! sbc_cpl_snd : send fields to the atmosphere
19	!!----------------------------------------------------------------------
20	USE dom_oce ! ocean space and time domain
21	USE sbc_oce ! Surface boundary condition: ocean fields
22	USE sbc_ice ! Surface boundary condition: ice fields
23	USE sbcapr
24	USE sbcdcy ! surface boundary condition: diurnal cycle
25	USE phycst ! physical constants
26	#if defined key_lim3
27	USE ice ! ice variables
28	#endif
29	#if defined key_lim2
30	USE par_ice_2 ! ice parameters
31	USE ice_2 ! ice variables
32	#endif
33	USE cpl_oasis3 ! OASIS3 coupling
34	USE geo2ocean !
35	USE oce , ONLY : tsn, un, vn, sshn, ub, vb, sshb, fraqsr_1lev
36	USE albedo !
37	USE in_out_manager ! I/O manager
38	USE iom ! NetCDF library
39	USE lib_mpp ! distribued memory computing library
40	USE wrk_nemo ! work arrays
41	USE timing ! Timing
42	USE lbclnk ! ocean lateral boundary conditions (or mpp link)
43	USE eosbn2
44	USE sbcrnf , ONLY : l_rnfcpl
45	#if defined key_cpl_carbon_cycle
46	USE p4zflx, ONLY : oce_co2
47	#endif
48	#if defined key_cice
49	USE ice_domain_size, only: ncat
50	#endif
51	#if defined key_lim3
52	USE limthd_dh ! for CALL lim_thd_snwblow
53	#endif
54	#if defined key_medusa
55	! RSRH Temporarily commented out until we get MEDUSA code USE trc
56	#endif
57
58
59
60
61	IMPLICIT NONE
62	PRIVATE
63
64	PUBLIC sbc_cpl_init ! routine called by sbcmod.F90
65	PUBLIC sbc_cpl_rcv ! routine called by sbc_ice_lim(_2).F90
66	PUBLIC sbc_cpl_snd ! routine called by step.F90
67	PUBLIC sbc_cpl_ice_tau ! routine called by sbc_ice_lim(_2).F90
68	PUBLIC sbc_cpl_ice_flx ! routine called by sbc_ice_lim(_2).F90
69	PUBLIC sbc_cpl_alloc ! routine called in sbcice_cice.F90
70
71	INTEGER, PARAMETER :: jpr_otx1 = 1 ! 3 atmosphere-ocean stress components on grid 1
72	INTEGER, PARAMETER :: jpr_oty1 = 2 !
73	INTEGER, PARAMETER :: jpr_otz1 = 3 !
74	INTEGER, PARAMETER :: jpr_otx2 = 4 ! 3 atmosphere-ocean stress components on grid 2
75	INTEGER, PARAMETER :: jpr_oty2 = 5 !
76	INTEGER, PARAMETER :: jpr_otz2 = 6 !
77	INTEGER, PARAMETER :: jpr_itx1 = 7 ! 3 atmosphere-ice stress components on grid 1
78	INTEGER, PARAMETER :: jpr_ity1 = 8 !
79	INTEGER, PARAMETER :: jpr_itz1 = 9 !
80	INTEGER, PARAMETER :: jpr_itx2 = 10 ! 3 atmosphere-ice stress components on grid 2
81	INTEGER, PARAMETER :: jpr_ity2 = 11 !
82	INTEGER, PARAMETER :: jpr_itz2 = 12 !
83	INTEGER, PARAMETER :: jpr_qsroce = 13 ! Qsr above the ocean
84	INTEGER, PARAMETER :: jpr_qsrice = 14 ! Qsr above the ice
85	INTEGER, PARAMETER :: jpr_qsrmix = 15
86	INTEGER, PARAMETER :: jpr_qnsoce = 16 ! Qns above the ocean
87	INTEGER, PARAMETER :: jpr_qnsice = 17 ! Qns above the ice
88	INTEGER, PARAMETER :: jpr_qnsmix = 18
89	INTEGER, PARAMETER :: jpr_rain = 19 ! total liquid precipitation (rain)
90	INTEGER, PARAMETER :: jpr_snow = 20 ! solid precipitation over the ocean (snow)
91	INTEGER, PARAMETER :: jpr_tevp = 21 ! total evaporation
92	INTEGER, PARAMETER :: jpr_ievp = 22 ! solid evaporation (sublimation)
93	INTEGER, PARAMETER :: jpr_sbpr = 23 ! sublimation - liquid precipitation - solid precipitation
94	INTEGER, PARAMETER :: jpr_semp = 24 ! solid freshwater budget (sublimation - snow)
95	INTEGER, PARAMETER :: jpr_oemp = 25 ! ocean freshwater budget (evap - precip)
96	INTEGER, PARAMETER :: jpr_w10m = 26 ! 10m wind
97	INTEGER, PARAMETER :: jpr_dqnsdt = 27 ! d(Q non solar)/d(temperature)
98	INTEGER, PARAMETER :: jpr_rnf = 28 ! runoffs
99	INTEGER, PARAMETER :: jpr_cal = 29 ! calving
100	INTEGER, PARAMETER :: jpr_taum = 30 ! wind stress module
101	INTEGER, PARAMETER :: jpr_co2 = 31
102	INTEGER, PARAMETER :: jpr_topm = 32 ! topmeltn
103	INTEGER, PARAMETER :: jpr_botm = 33 ! botmeltn
104	INTEGER, PARAMETER :: jpr_sflx = 34 ! salt flux
105	INTEGER, PARAMETER :: jpr_toce = 35 ! ocean temperature
106	INTEGER, PARAMETER :: jpr_soce = 36 ! ocean salinity
107	INTEGER, PARAMETER :: jpr_ocx1 = 37 ! ocean current on grid 1
108	INTEGER, PARAMETER :: jpr_ocy1 = 38 !
109	INTEGER, PARAMETER :: jpr_ssh = 39 ! sea surface height
110	INTEGER, PARAMETER :: jpr_fice = 40 ! ice fraction
111	INTEGER, PARAMETER :: jpr_e3t1st = 41 ! first T level thickness
112	INTEGER, PARAMETER :: jpr_fraqsr = 42 ! fraction of solar net radiation absorbed in the first ocean level
113	INTEGER, PARAMETER :: jpr_ts_ice = 43 ! skin temperature of sea-ice (used for melt-ponds)
114	INTEGER, PARAMETER :: jpr_grnm = 44 ! Greenland ice mass
115	INTEGER, PARAMETER :: jpr_antm = 45 ! Antarctic ice mass
116	INTEGER, PARAMETER :: jpr_atm_pco2 = 46 ! Incoming atm CO2 flux
117	INTEGER, PARAMETER :: jpr_atm_dust = 47 ! Incoming atm aggregate dust
118	INTEGER, PARAMETER :: jprcv = 47 ! total number of fields received
119
120	INTEGER, PARAMETER :: jps_fice = 1 ! ice fraction sent to the atmosphere
121	INTEGER, PARAMETER :: jps_toce = 2 ! ocean temperature
122	INTEGER, PARAMETER :: jps_tice = 3 ! ice temperature
123	INTEGER, PARAMETER :: jps_tmix = 4 ! mixed temperature (ocean+ice)
124	INTEGER, PARAMETER :: jps_albice = 5 ! ice albedo
125	INTEGER, PARAMETER :: jps_albmix = 6 ! mixed albedo
126	INTEGER, PARAMETER :: jps_hice = 7 ! ice thickness
127	INTEGER, PARAMETER :: jps_hsnw = 8 ! snow thickness
128	INTEGER, PARAMETER :: jps_ocx1 = 9 ! ocean current on grid 1
129	INTEGER, PARAMETER :: jps_ocy1 = 10 !
130	INTEGER, PARAMETER :: jps_ocz1 = 11 !
131	INTEGER, PARAMETER :: jps_ivx1 = 12 ! ice current on grid 1
132	INTEGER, PARAMETER :: jps_ivy1 = 13 !
133	INTEGER, PARAMETER :: jps_ivz1 = 14 !
134	INTEGER, PARAMETER :: jps_co2 = 15
135	INTEGER, PARAMETER :: jps_soce = 16 ! ocean salinity
136	INTEGER, PARAMETER :: jps_ssh = 17 ! sea surface height
137	INTEGER, PARAMETER :: jps_qsroce = 18 ! Qsr above the ocean
138	INTEGER, PARAMETER :: jps_qnsoce = 19 ! Qns above the ocean
139	INTEGER, PARAMETER :: jps_oemp = 20 ! ocean freshwater budget (evap - precip)
140	INTEGER, PARAMETER :: jps_sflx = 21 ! salt flux
141	INTEGER, PARAMETER :: jps_otx1 = 22 ! 2 atmosphere-ocean stress components on grid 1
142	INTEGER, PARAMETER :: jps_oty1 = 23 !
143	INTEGER, PARAMETER :: jps_rnf = 24 ! runoffs
144	INTEGER, PARAMETER :: jps_taum = 25 ! wind stress module
145	INTEGER, PARAMETER :: jps_fice2 = 26 ! ice fraction sent to OPA (by SAS when doing SAS-OPA coupling)
146	INTEGER, PARAMETER :: jps_e3t1st = 27 ! first level depth (vvl)
147	INTEGER, PARAMETER :: jps_fraqsr = 28 ! fraction of solar net radiation absorbed in the first ocean level
148	INTEGER, PARAMETER :: jps_bio_co2 = 29 ! MEDUSA air-sea CO2 flux in
149	INTEGER, PARAMETER :: jps_bio_dms = 30 ! MEDUSA DMS surface concentration in
150	INTEGER, PARAMETER :: jpsnd = 30 ! total number of fields sent
151
152	REAL(wp), PARAMETER :: dms_unit_conv = 1.0e+6 ! Coversion factor to get outgong DMS in standard units for coupling
153	! i.e. specifically nmol/L (= umol/m3)
154
155	! !! namelist namsbc_cpl
156	TYPE :: FLD_C
157	CHARACTER(len = 32) :: cldes ! desciption of the coupling strategy
158	CHARACTER(len = 32) :: clcat ! multiple ice categories strategy
159	CHARACTER(len = 32) :: clvref ! reference of vector ('spherical' or 'cartesian')
160	CHARACTER(len = 32) :: clvor ! orientation of vector fields ('eastward-northward' or 'local grid')
161	CHARACTER(len = 32) :: clvgrd ! grids on which is located the vector fields
162	END TYPE FLD_C
163	! Send to the atmosphere !
164	TYPE(FLD_C) :: sn_snd_temp, sn_snd_alb, sn_snd_thick, sn_snd_crt, sn_snd_co2, sn_snd_cond, sn_snd_mpnd, sn_snd_sstfrz, sn_snd_thick1
165	TYPE(FLD_C) :: sn_snd_bio_co2, sn_snd_bio_dms
166	! Received from the atmosphere !
167	TYPE(FLD_C) :: sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_dqnsdt, sn_rcv_qsr, sn_rcv_qns, sn_rcv_emp, sn_rcv_rnf
168	TYPE(FLD_C) :: sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2, sn_rcv_ts_ice, sn_rcv_grnm, sn_rcv_antm
169	TYPE(FLD_C) :: sn_rcv_atm_pco2, sn_rcv_atm_dust
170	! Other namelist parameters !
171	INTEGER :: nn_cplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data
172	LOGICAL :: ln_usecplmask ! use a coupling mask file to merge data received from several models
173	! -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel)
174	TYPE :: DYNARR
175	REAL(wp), POINTER, DIMENSION(:,:,:) :: z3
176	END TYPE DYNARR
177
178	TYPE( DYNARR ), SAVE, DIMENSION(jprcv) :: frcv ! all fields recieved from the atmosphere
179
180	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: albedo_oce_mix ! ocean albedo sent to atmosphere (mix clear/overcast sky)
181
182	INTEGER , ALLOCATABLE, SAVE, DIMENSION( :) :: nrcvinfo ! OASIS info argument
183
184
185	!! Substitution
186	# include "domzgr_substitute.h90"
187	# include "vectopt_loop_substitute.h90"
188	!!----------------------------------------------------------------------
189	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
190	!! $Id$
191	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
192	!!----------------------------------------------------------------------
193
194	CONTAINS
195
196	INTEGER FUNCTION sbc_cpl_alloc()
197	!!----------------------------------------------------------------------
198	!! * FUNCTION sbc_cpl_alloc *
199	!!----------------------------------------------------------------------
200	INTEGER :: ierr(3)
201	!!----------------------------------------------------------------------
202	ierr(:) = 0
203	!
204	ALLOCATE( albedo_oce_mix(jpi,jpj), nrcvinfo(jprcv), STAT=ierr(1) )
205
206	#if ! defined key_lim3 && ! defined key_lim2 && ! defined key_cice
207	ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) ) ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init)
208	#endif
209	ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) )
210	!
211	sbc_cpl_alloc = MAXVAL( ierr )
212	IF( lk_mpp ) CALL mpp_sum ( sbc_cpl_alloc )
213	IF( sbc_cpl_alloc > 0 ) CALL ctl_warn('sbc_cpl_alloc: allocation of arrays failed')
214	!
215	END FUNCTION sbc_cpl_alloc
216
217
218	SUBROUTINE sbc_cpl_init( k_ice )
219	!!----------------------------------------------------------------------
220	!! * ROUTINE sbc_cpl_init *
221	!!
222	!! ** Purpose : Initialisation of send and received information from
223	!! the atmospheric component
224	!!
225	!! ** Method : * Read namsbc_cpl namelist
226	!! * define the receive interface
227	!! * define the send interface
228	!! * initialise the OASIS coupler
229	!!----------------------------------------------------------------------
230	INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3)
231	!!
232	INTEGER :: jn ! dummy loop index
233	INTEGER :: ios ! Local integer output status for namelist read
234	INTEGER :: inum
235	REAL(wp), POINTER, DIMENSION(:,:) :: zacs, zaos
236	!!
237	NAMELIST/namsbc_cpl/ sn_snd_temp, sn_snd_alb , sn_snd_thick , sn_snd_crt , sn_snd_co2, &
238	& sn_snd_bio_co2, sn_snd_bio_dms, &
239	& sn_snd_cond, sn_snd_mpnd , sn_snd_sstfrz, sn_snd_thick1, &
240	& sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr, &
241	& sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , sn_rcv_iceflx, &
242	& sn_rcv_atm_pco2, sn_rcv_atm_dust, &
243	& sn_rcv_co2 , sn_rcv_grnm , sn_rcv_antm , sn_rcv_ts_ice, nn_cplmodel , &
244	& ln_usecplmask, ln_coupled_iceshelf_fluxes, rn_greenland_calving_fraction, &
245	& rn_antarctica_calving_fraction, rn_iceshelf_fluxes_tolerance
246
247	!!---------------------------------------------------------------------
248	!
249	IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_init')
250	!
251	CALL wrk_alloc( jpi,jpj, zacs, zaos )
252
253	! ================================ !
254	! Namelist informations !
255	! ================================ !
256
257	REWIND( numnam_ref ) ! Namelist namsbc_cpl in reference namelist : Variables for OASIS coupling
258	READ ( numnam_ref, namsbc_cpl, IOSTAT = ios, ERR = 901)
259	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in reference namelist', lwp )
260
261	REWIND( numnam_cfg ) ! Namelist namsbc_cpl in configuration namelist : Variables for OASIS coupling
262	READ ( numnam_cfg, namsbc_cpl, IOSTAT = ios, ERR = 902 )
263	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in configuration namelist', lwp )
264	IF(lwm) WRITE ( numond, namsbc_cpl )
265
266	IF(lwp) THEN ! control print
267	WRITE(numout,*)
268	WRITE(numout,*)'sbc_cpl_init : namsbc_cpl namelist '
269	WRITE(numout,*)'~~~~~~~~~~~~'
270	ENDIF
271	IF( lwp .AND. ln_cpl ) THEN ! control print
272	WRITE(numout,*)' received fields (mutiple ice categories)'
273	WRITE(numout,*)' 10m wind module = ', TRIM(sn_rcv_w10m%cldes ), ' (', TRIM(sn_rcv_w10m%clcat ), ')'
274	WRITE(numout,*)' stress module = ', TRIM(sn_rcv_taumod%cldes), ' (', TRIM(sn_rcv_taumod%clcat), ')'
275	WRITE(numout,*)' surface stress = ', TRIM(sn_rcv_tau%cldes ), ' (', TRIM(sn_rcv_tau%clcat ), ')'
276	WRITE(numout,*)' - referential = ', sn_rcv_tau%clvref
277	WRITE(numout,*)' - orientation = ', sn_rcv_tau%clvor
278	WRITE(numout,*)' - mesh = ', sn_rcv_tau%clvgrd
279	WRITE(numout,*)' non-solar heat flux sensitivity = ', TRIM(sn_rcv_dqnsdt%cldes), ' (', TRIM(sn_rcv_dqnsdt%clcat), ')'
280	WRITE(numout,*)' solar heat flux = ', TRIM(sn_rcv_qsr%cldes ), ' (', TRIM(sn_rcv_qsr%clcat ), ')'
281	WRITE(numout,*)' non-solar heat flux = ', TRIM(sn_rcv_qns%cldes ), ' (', TRIM(sn_rcv_qns%clcat ), ')'
282	WRITE(numout,*)' freshwater budget = ', TRIM(sn_rcv_emp%cldes ), ' (', TRIM(sn_rcv_emp%clcat ), ')'
283	WRITE(numout,*)' runoffs = ', TRIM(sn_rcv_rnf%cldes ), ' (', TRIM(sn_rcv_rnf%clcat ), ')'
284	WRITE(numout,*)' calving = ', TRIM(sn_rcv_cal%cldes ), ' (', TRIM(sn_rcv_cal%clcat ), ')'
285	WRITE(numout,*)' sea ice heat fluxes = ', TRIM(sn_rcv_iceflx%cldes), ' (', TRIM(sn_rcv_iceflx%clcat), ')'
286	WRITE(numout,*)' atm co2 = ', TRIM(sn_rcv_co2%cldes ), ' (', TRIM(sn_rcv_co2%clcat ), ')'
287	WRITE(numout,*)' atm pco2 = ', TRIM(sn_rcv_atm_pco2%cldes), ' (', TRIM(sn_rcv_atm_pco2%clcat), ')'
288	WRITE(numout,*)' atm dust = ', TRIM(sn_rcv_atm_dust%cldes), ' (', TRIM(sn_rcv_atm_dust%clcat), ')'
289	WRITE(numout,*)' sent fields (multiple ice categories)'
290	WRITE(numout,*)' surface temperature = ', TRIM(sn_snd_temp%cldes ), ' (', TRIM(sn_snd_temp%clcat ), ')'
291	WRITE(numout,*)' albedo = ', TRIM(sn_snd_alb%cldes ), ' (', TRIM(sn_snd_alb%clcat ), ')'
292	WRITE(numout,*)' ice/snow thickness = ', TRIM(sn_snd_thick%cldes ), ' (', TRIM(sn_snd_thick%clcat ), ')'
293	WRITE(numout,*)' surface current = ', TRIM(sn_snd_crt%cldes ), ' (', TRIM(sn_snd_crt%clcat ), ')'
294	WRITE(numout,*)' - referential = ', sn_snd_crt%clvref
295	WRITE(numout,*)' - orientation = ', sn_snd_crt%clvor
296	WRITE(numout,*)' - mesh = ', sn_snd_crt%clvgrd
297	WRITE(numout,*)' oce co2 flux = ', TRIM(sn_snd_co2%cldes ), ' (', TRIM(sn_snd_co2%clcat ), ')'
298	WRITE(numout,*)' bio co2 flux = ', TRIM(sn_snd_bio_co2%cldes), ' (', TRIM(sn_snd_bio_co2%clcat), ')'
299	WRITE(numout,*)' bio dms flux = ', TRIM(sn_snd_bio_dms%cldes), ' (', TRIM(sn_snd_bio_dms%clcat), ')'
300	WRITE(numout,*)' nn_cplmodel = ', nn_cplmodel
301	WRITE(numout,*)' ln_usecplmask = ', ln_usecplmask
302	WRITE(numout,*)' ln_coupled_iceshelf_fluxes = ', ln_coupled_iceshelf_fluxes
303	WRITE(numout,*)' rn_greenland_calving_fraction = ', rn_greenland_calving_fraction
304	WRITE(numout,*)' rn_antarctica_calving_fraction = ', rn_antarctica_calving_fraction
305	WRITE(numout,*)' rn_iceshelf_fluxes_tolerance = ', rn_iceshelf_fluxes_tolerance
306	ENDIF
307
308	! ! allocate sbccpl arrays
309	IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' )
310
311	! ================================ !
312	! Define the receive interface !
313	! ================================ !
314	nrcvinfo(:) = OASIS_idle ! needed by nrcvinfo(jpr_otx1) if we do not receive ocean stress
315
316	! for each field: define the OASIS name (srcv(:)%clname)
317	! define receive or not from the namelist parameters (srcv(:)%laction)
318	! define the north fold type of lbc (srcv(:)%nsgn)
319
320	! default definitions of srcv
321	srcv(:)%laction = .FALSE. ; srcv(:)%clgrid = 'T' ; srcv(:)%nsgn = 1. ; srcv(:)%nct = 1
322
323	! ! ------------------------- !
324	! ! ice and ocean wind stress !
325	! ! ------------------------- !
326	! ! Name
327	srcv(jpr_otx1)%clname = 'O_OTaux1' ! 1st ocean component on grid ONE (T or U)
328	srcv(jpr_oty1)%clname = 'O_OTauy1' ! 2nd - - - -
329	srcv(jpr_otz1)%clname = 'O_OTauz1' ! 3rd - - - -
330	srcv(jpr_otx2)%clname = 'O_OTaux2' ! 1st ocean component on grid TWO (V)
331	srcv(jpr_oty2)%clname = 'O_OTauy2' ! 2nd - - - -
332	srcv(jpr_otz2)%clname = 'O_OTauz2' ! 3rd - - - -
333	!
334	srcv(jpr_itx1)%clname = 'O_ITaux1' ! 1st ice component on grid ONE (T, F, I or U)
335	srcv(jpr_ity1)%clname = 'O_ITauy1' ! 2nd - - - -
336	srcv(jpr_itz1)%clname = 'O_ITauz1' ! 3rd - - - -
337	srcv(jpr_itx2)%clname = 'O_ITaux2' ! 1st ice component on grid TWO (V)
338	srcv(jpr_ity2)%clname = 'O_ITauy2' ! 2nd - - - -
339	srcv(jpr_itz2)%clname = 'O_ITauz2' ! 3rd - - - -
340	!
341	! Vectors: change of sign at north fold ONLY if on the local grid
342	IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) srcv(jpr_otx1:jpr_itz2)%nsgn = -1.
343
344	! ! Set grid and action
345	SELECT CASE( TRIM( sn_rcv_tau%clvgrd ) ) ! 'T', 'U,V', 'U,V,I', 'U,V,F', 'T,I', 'T,F', or 'T,U,V'
346	CASE( 'T' )
347	srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point
348	srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1
349	srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1
350	CASE( 'U,V' )
351	srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point
352	srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point
353	srcv(jpr_itx1:jpr_itz1)%clgrid = 'U' ! ice components given at U-point
354	srcv(jpr_itx2:jpr_itz2)%clgrid = 'V' ! and V-point
355	srcv(jpr_otx1:jpr_itz2)%laction = .TRUE. ! receive oce and ice components on both grid 1 & 2
356	CASE( 'U,V,T' )
357	srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point
358	srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point
359	srcv(jpr_itx1:jpr_itz1)%clgrid = 'T' ! ice components given at T-point
360	srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2
361	srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only
362	CASE( 'U,V,I' )
363	srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point
364	srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point
365	srcv(jpr_itx1:jpr_itz1)%clgrid = 'I' ! ice components given at I-point
366	srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2
367	srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only
368	CASE( 'U,V,F' )
369	srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point
370	srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point
371	srcv(jpr_itx1:jpr_itz1)%clgrid = 'F' ! ice components given at F-point
372	!srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2
373	! Currently needed for HadGEM3 - but shouldn't affect anyone else for the moment
374	srcv(jpr_otx1)%laction = .TRUE.
375	srcv(jpr_oty1)%laction = .TRUE.
376	!
377	srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only
378	CASE( 'T,I' )
379	srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point
380	srcv(jpr_itx1:jpr_itz1)%clgrid = 'I' ! ice components given at I-point
381	srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1
382	srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1
383	CASE( 'T,F' )
384	srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point
385	srcv(jpr_itx1:jpr_itz1)%clgrid = 'F' ! ice components given at F-point
386	srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1
387	srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1
388	CASE( 'T,U,V' )
389	srcv(jpr_otx1:jpr_otz1)%clgrid = 'T' ! oce components given at T-point
390	srcv(jpr_itx1:jpr_itz1)%clgrid = 'U' ! ice components given at U-point
391	srcv(jpr_itx2:jpr_itz2)%clgrid = 'V' ! and V-point
392	srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 only
393	srcv(jpr_itx1:jpr_itz2)%laction = .TRUE. ! receive ice components on grid 1 & 2
394	CASE default
395	CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_tau%clvgrd' )
396	END SELECT
397	!
398	IF( TRIM( sn_rcv_tau%clvref ) == 'spherical' ) & ! spherical: 3rd component not received
399	& srcv( (/jpr_otz1, jpr_otz2, jpr_itz1, jpr_itz2/) )%laction = .FALSE.
400	!
401	IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) THEN ! already on local grid -> no need of the second grid
402	srcv(jpr_otx2:jpr_otz2)%laction = .FALSE.
403	srcv(jpr_itx2:jpr_itz2)%laction = .FALSE.
404	srcv(jpr_oty1)%clgrid = srcv(jpr_oty2)%clgrid ! not needed but cleaner...
405	srcv(jpr_ity1)%clgrid = srcv(jpr_ity2)%clgrid ! not needed but cleaner...
406	ENDIF
407	!
408	IF( TRIM( sn_rcv_tau%cldes ) /= 'oce and ice' ) THEN ! 'oce and ice' case ocean stress on ocean mesh used
409	srcv(jpr_itx1:jpr_itz2)%laction = .FALSE. ! ice components not received
410	srcv(jpr_itx1)%clgrid = 'U' ! ocean stress used after its transformation
411	srcv(jpr_ity1)%clgrid = 'V' ! i.e. it is always at U- & V-points for i- & j-comp. resp.
412	ENDIF
413
414	! ! ------------------------- !
415	! ! freshwater budget ! E-P
416	! ! ------------------------- !
417	! we suppose that atmosphere modele do not make the difference between precipiration (liquide or solid)
418	! over ice of free ocean within the same atmospheric cell.cd
419	srcv(jpr_rain)%clname = 'OTotRain' ! Rain = liquid precipitation
420	srcv(jpr_snow)%clname = 'OTotSnow' ! Snow = solid precipitation
421	srcv(jpr_tevp)%clname = 'OTotEvap' ! total evaporation (over oce + ice sublimation)
422	srcv(jpr_ievp)%clname = 'OIceEvap' ! evaporation over ice = sublimation
423	srcv(jpr_sbpr)%clname = 'OSubMPre' ! sublimation - liquid precipitation - solid precipitation
424	srcv(jpr_semp)%clname = 'OISubMSn' ! ice solid water budget = sublimation - solid precipitation
425	srcv(jpr_oemp)%clname = 'OOEvaMPr' ! ocean water budget = ocean Evap - ocean precip
426	SELECT CASE( TRIM( sn_rcv_emp%cldes ) )
427	CASE( 'none' ) ! nothing to do
428	CASE( 'oce only' ) ; srcv( jpr_oemp )%laction = .TRUE.
429	CASE( 'conservative' )
430	srcv( (/jpr_rain, jpr_snow, jpr_ievp, jpr_tevp/) )%laction = .TRUE.
431	IF ( k_ice <= 1 ) srcv(jpr_ievp)%laction = .FALSE.
432	CASE( 'oce and ice' ) ; srcv( (/jpr_ievp, jpr_sbpr, jpr_semp, jpr_oemp/) )%laction = .TRUE.
433	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_emp%cldes' )
434	END SELECT
435
436	! ! ------------------------- !
437	! ! Runoffs & Calving !
438	! ! ------------------------- !
439	srcv(jpr_rnf )%clname = 'O_Runoff'
440	IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN
441	srcv(jpr_rnf)%laction = .TRUE.
442	l_rnfcpl = .TRUE. ! -> no need to read runoffs in sbcrnf
443	ln_rnf = nn_components /= jp_iam_sas ! -> force to go through sbcrnf if not sas
444	IF(lwp) WRITE(numout,*)
445	IF(lwp) WRITE(numout,*) ' runoffs received from oasis -> force ln_rnf = ', ln_rnf
446	ENDIF
447	!
448	srcv(jpr_cal )%clname = 'OCalving' ; IF( TRIM( sn_rcv_cal%cldes ) == 'coupled' ) srcv(jpr_cal)%laction = .TRUE.
449
450	! ! ------------------------- !
451	! ! non solar radiation ! Qns
452	! ! ------------------------- !
453	srcv(jpr_qnsoce)%clname = 'O_QnsOce'
454	srcv(jpr_qnsice)%clname = 'O_QnsIce'
455	srcv(jpr_qnsmix)%clname = 'O_QnsMix'
456	SELECT CASE( TRIM( sn_rcv_qns%cldes ) )
457	CASE( 'none' ) ! nothing to do
458	CASE( 'oce only' ) ; srcv( jpr_qnsoce )%laction = .TRUE.
459	CASE( 'conservative' ) ; srcv( (/jpr_qnsice, jpr_qnsmix/) )%laction = .TRUE.
460	CASE( 'oce and ice' ) ; srcv( (/jpr_qnsice, jpr_qnsoce/) )%laction = .TRUE.
461	CASE( 'mixed oce-ice' ) ; srcv( jpr_qnsmix )%laction = .TRUE.
462	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qns%cldes' )
463	END SELECT
464	IF( TRIM( sn_rcv_qns%cldes ) == 'mixed oce-ice' .AND. jpl > 1 ) &
465	CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qns%cldes not currently allowed to be mixed oce-ice for multi-category ice' )
466	! ! ------------------------- !
467	! ! solar radiation ! Qsr
468	! ! ------------------------- !
469	srcv(jpr_qsroce)%clname = 'O_QsrOce'
470	srcv(jpr_qsrice)%clname = 'O_QsrIce'
471	srcv(jpr_qsrmix)%clname = 'O_QsrMix'
472	SELECT CASE( TRIM( sn_rcv_qsr%cldes ) )
473	CASE( 'none' ) ! nothing to do
474	CASE( 'oce only' ) ; srcv( jpr_qsroce )%laction = .TRUE.
475	CASE( 'conservative' ) ; srcv( (/jpr_qsrice, jpr_qsrmix/) )%laction = .TRUE.
476	CASE( 'oce and ice' ) ; srcv( (/jpr_qsrice, jpr_qsroce/) )%laction = .TRUE.
477	CASE( 'mixed oce-ice' ) ; srcv( jpr_qsrmix )%laction = .TRUE.
478	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qsr%cldes' )
479	END SELECT
480	IF( TRIM( sn_rcv_qsr%cldes ) == 'mixed oce-ice' .AND. jpl > 1 ) &
481	CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qsr%cldes not currently allowed to be mixed oce-ice for multi-category ice' )
482	! ! ------------------------- !
483	! ! non solar sensitivity ! d(Qns)/d(T)
484	! ! ------------------------- !
485	srcv(jpr_dqnsdt)%clname = 'O_dQnsdT'
486	IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'coupled' ) srcv(jpr_dqnsdt)%laction = .TRUE.
487	!
488	! non solar sensitivity mandatory for LIM ice model
489	IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. k_ice /= 0 .AND. k_ice /= 4 .AND. nn_components /= jp_iam_sas ) &
490	CALL ctl_stop( 'sbc_cpl_init: sn_rcv_dqnsdt%cldes must be coupled in namsbc_cpl namelist' )
491	! non solar sensitivity mandatory for mixed oce-ice solar radiation coupling technique
492	IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. TRIM( sn_rcv_qns%cldes ) == 'mixed oce-ice' ) &
493	CALL ctl_stop( 'sbc_cpl_init: namsbc_cpl namelist mismatch between sn_rcv_qns%cldes and sn_rcv_dqnsdt%cldes' )
494	! ! ------------------------- !
495	! ! 10m wind module !
496	! ! ------------------------- !
497	srcv(jpr_w10m)%clname = 'O_Wind10' ; IF( TRIM(sn_rcv_w10m%cldes ) == 'coupled' ) srcv(jpr_w10m)%laction = .TRUE.
498	!
499	! ! ------------------------- !
500	! ! wind stress module !
501	! ! ------------------------- !
502	srcv(jpr_taum)%clname = 'O_TauMod' ; IF( TRIM(sn_rcv_taumod%cldes) == 'coupled' ) srcv(jpr_taum)%laction = .TRUE.
503	lhftau = srcv(jpr_taum)%laction
504
505	! ! ------------------------- !
506	! ! Atmospheric CO2 !
507	! ! ------------------------- !
508	srcv(jpr_co2 )%clname = 'O_AtmCO2' ; IF( TRIM(sn_rcv_co2%cldes ) == 'coupled' ) srcv(jpr_co2 )%laction = .TRUE.
509
510
511	! ! --------------------------------------- !
512	! ! Incoming CO2 and DUST fluxes for MEDUSA !
513	! ! --------------------------------------- !
514	srcv(jpr_atm_pco2)%clname = 'OATMPCO2'
515
516	IF (TRIM(sn_rcv_atm_pco2%cldes) == 'coupled') THEN
517	srcv(jpr_atm_pco2)%laction = .TRUE.
518	END IF
519
520	srcv(jpr_atm_dust)%clname = 'OATMDUST'
521	IF (TRIM(sn_rcv_atm_dust%cldes) == 'coupled') THEN
522	srcv(jpr_atm_dust)%laction = .TRUE.
523	END IF
524
525	! ! ------------------------- !
526	! ! topmelt and botmelt !
527	! ! ------------------------- !
528	srcv(jpr_topm )%clname = 'OTopMlt'
529	srcv(jpr_botm )%clname = 'OBotMlt'
530	IF( TRIM(sn_rcv_iceflx%cldes) == 'coupled' ) THEN
531	IF ( TRIM( sn_rcv_iceflx%clcat ) == 'yes' ) THEN
532	srcv(jpr_topm:jpr_botm)%nct = jpl
533	ELSE
534	CALL ctl_stop( 'sbc_cpl_init: sn_rcv_iceflx%clcat should always be set to yes currently' )
535	ENDIF
536	srcv(jpr_topm:jpr_botm)%laction = .TRUE.
537	ENDIF
538	! ! ------------------------------- !
539	! ! OPA-SAS coupling - rcv by opa !
540	! ! ------------------------------- !
541	srcv(jpr_sflx)%clname = 'O_SFLX'
542	srcv(jpr_fice)%clname = 'RIceFrc'
543	!
544	IF( nn_components == jp_iam_opa ) THEN ! OPA coupled to SAS via OASIS: force received field by OPA (sent by SAS)
545	srcv(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling
546	srcv(:)%clgrid = 'T' ! force default definition in case of opa <-> sas coupling
547	srcv(:)%nsgn = 1. ! force default definition in case of opa <-> sas coupling
548	srcv( (/jpr_qsroce, jpr_qnsoce, jpr_oemp, jpr_sflx, jpr_fice, jpr_otx1, jpr_oty1, jpr_taum/) )%laction = .TRUE.
549	srcv(jpr_otx1)%clgrid = 'U' ! oce components given at U-point
550	srcv(jpr_oty1)%clgrid = 'V' ! and V-point
551	! Vectors: change of sign at north fold ONLY if on the local grid
552	srcv( (/jpr_otx1,jpr_oty1/) )%nsgn = -1.
553	sn_rcv_tau%clvgrd = 'U,V'
554	sn_rcv_tau%clvor = 'local grid'
555	sn_rcv_tau%clvref = 'spherical'
556	sn_rcv_emp%cldes = 'oce only'
557	!
558	IF(lwp) THEN ! control print
559	WRITE(numout,*)
560	WRITE(numout,*)' Special conditions for SAS-OPA coupling '
561	WRITE(numout,*)' OPA component '
562	WRITE(numout,*)
563	WRITE(numout,*)' received fields from SAS component '
564	WRITE(numout,*)' ice cover '
565	WRITE(numout,*)' oce only EMP '
566	WRITE(numout,*)' salt flux '
567	WRITE(numout,*)' mixed oce-ice solar flux '
568	WRITE(numout,*)' mixed oce-ice non solar flux '
569	WRITE(numout,*)' wind stress U,V on local grid and sperical coordinates '
570	WRITE(numout,*)' wind stress module'
571	WRITE(numout,*)
572	ENDIF
573	ENDIF
574	! ! -------------------------------- !
575	! ! OPA-SAS coupling - rcv by sas !
576	! ! -------------------------------- !
577	srcv(jpr_toce )%clname = 'I_SSTSST'
578	srcv(jpr_soce )%clname = 'I_SSSal'
579	srcv(jpr_ocx1 )%clname = 'I_OCurx1'
580	srcv(jpr_ocy1 )%clname = 'I_OCury1'
581	srcv(jpr_ssh )%clname = 'I_SSHght'
582	srcv(jpr_e3t1st)%clname = 'I_E3T1st'
583	srcv(jpr_fraqsr)%clname = 'I_FraQsr'
584	!
585	IF( nn_components == jp_iam_sas ) THEN
586	IF( .NOT. ln_cpl ) srcv(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling
587	IF( .NOT. ln_cpl ) srcv(:)%clgrid = 'T' ! force default definition in case of opa <-> sas coupling
588	IF( .NOT. ln_cpl ) srcv(:)%nsgn = 1. ! force default definition in case of opa <-> sas coupling
589	srcv( (/jpr_toce, jpr_soce, jpr_ssh, jpr_fraqsr, jpr_ocx1, jpr_ocy1/) )%laction = .TRUE.
590	srcv( jpr_e3t1st )%laction = lk_vvl
591	srcv(jpr_ocx1)%clgrid = 'U' ! oce components given at U-point
592	srcv(jpr_ocy1)%clgrid = 'V' ! and V-point
593	! Vectors: change of sign at north fold ONLY if on the local grid
594	srcv(jpr_ocx1:jpr_ocy1)%nsgn = -1.
595	! Change first letter to couple with atmosphere if already coupled OPA
596	! this is nedeed as each variable name used in the namcouple must be unique:
597	! for example O_Runoff received by OPA from SAS and therefore O_Runoff received by SAS from the Atmosphere
598	DO jn = 1, jprcv
599	IF ( srcv(jn)%clname(1:1) == "O" ) srcv(jn)%clname = "S"//srcv(jn)%clname(2:LEN(srcv(jn)%clname))
600	END DO
601	!
602	IF(lwp) THEN ! control print
603	WRITE(numout,*)
604	WRITE(numout,*)' Special conditions for SAS-OPA coupling '
605	WRITE(numout,*)' SAS component '
606	WRITE(numout,*)
607	IF( .NOT. ln_cpl ) THEN
608	WRITE(numout,*)' received fields from OPA component '
609	ELSE
610	WRITE(numout,*)' Additional received fields from OPA component : '
611	ENDIF
612	WRITE(numout,*)' sea surface temperature (Celcius) '
613	WRITE(numout,*)' sea surface salinity '
614	WRITE(numout,*)' surface currents '
615	WRITE(numout,*)' sea surface height '
616	WRITE(numout,*)' thickness of first ocean T level '
617	WRITE(numout,*)' fraction of solar net radiation absorbed in the first ocean level'
618	WRITE(numout,*)
619	ENDIF
620	ENDIF
621
622	! =================================================== !
623	! Allocate all parts of frcv used for received fields !
624	! =================================================== !
625	DO jn = 1, jprcv
626	IF ( srcv(jn)%laction ) ALLOCATE( frcv(jn)%z3(jpi,jpj,srcv(jn)%nct) )
627	END DO
628	! Allocate taum part of frcv which is used even when not received as coupling field
629	IF ( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(jpi,jpj,srcv(jpr_taum)%nct) )
630	! Allocate w10m part of frcv which is used even when not received as coupling field
631	IF ( .NOT. srcv(jpr_w10m)%laction ) ALLOCATE( frcv(jpr_w10m)%z3(jpi,jpj,srcv(jpr_w10m)%nct) )
632	! Allocate jpr_otx1 part of frcv which is used even when not received as coupling field
633	IF ( .NOT. srcv(jpr_otx1)%laction ) ALLOCATE( frcv(jpr_otx1)%z3(jpi,jpj,srcv(jpr_otx1)%nct) )
634	IF ( .NOT. srcv(jpr_oty1)%laction ) ALLOCATE( frcv(jpr_oty1)%z3(jpi,jpj,srcv(jpr_oty1)%nct) )
635	! Allocate itx1 and ity1 as they are used in sbc_cpl_ice_tau even if srcv(jpr_itx1)%laction = .FALSE.
636	IF( k_ice /= 0 ) THEN
637	IF ( .NOT. srcv(jpr_itx1)%laction ) ALLOCATE( frcv(jpr_itx1)%z3(jpi,jpj,srcv(jpr_itx1)%nct) )
638	IF ( .NOT. srcv(jpr_ity1)%laction ) ALLOCATE( frcv(jpr_ity1)%z3(jpi,jpj,srcv(jpr_ity1)%nct) )
639	END IF
640
641	! ================================ !
642	! Define the send interface !
643	! ================================ !
644	! for each field: define the OASIS name (ssnd(:)%clname)
645	! define send or not from the namelist parameters (ssnd(:)%laction)
646	! define the north fold type of lbc (ssnd(:)%nsgn)
647
648	! default definitions of nsnd
649	ssnd(:)%laction = .FALSE. ; ssnd(:)%clgrid = 'T' ; ssnd(:)%nsgn = 1. ; ssnd(:)%nct = 1
650
651	! ! ------------------------- !
652	! ! Surface temperature !
653	! ! ------------------------- !
654	ssnd(jps_toce)%clname = 'O_SSTSST'
655	ssnd(jps_tice)%clname = 'O_TepIce'
656	ssnd(jps_tmix)%clname = 'O_TepMix'
657	SELECT CASE( TRIM( sn_snd_temp%cldes ) )
658	CASE( 'none' ) ! nothing to do
659	CASE( 'oce only' ) ; ssnd( jps_toce )%laction = .TRUE.
660	CASE( 'oce and ice' , 'weighted oce and ice' )
661	ssnd( (/jps_toce, jps_tice/) )%laction = .TRUE.
662	IF ( TRIM( sn_snd_temp%clcat ) == 'yes' ) ssnd(jps_tice)%nct = jpl
663	CASE( 'mixed oce-ice' ) ; ssnd( jps_tmix )%laction = .TRUE.
664	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_temp%cldes' )
665	END SELECT
666
667	! ! ------------------------- !
668	! ! Albedo !
669	! ! ------------------------- !
670	ssnd(jps_albice)%clname = 'O_AlbIce'
671	ssnd(jps_albmix)%clname = 'O_AlbMix'
672	SELECT CASE( TRIM( sn_snd_alb%cldes ) )
673	CASE( 'none' ) ! nothing to do
674	CASE( 'ice' , 'weighted ice' ) ; ssnd(jps_albice)%laction = .TRUE.
675	CASE( 'mixed oce-ice' ) ; ssnd(jps_albmix)%laction = .TRUE.
676	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_alb%cldes' )
677	END SELECT
678	!
679	! Need to calculate oceanic albedo if
680	! 1. sending mixed oce-ice albedo or
681	! 2. receiving mixed oce-ice solar radiation
682	IF ( TRIM ( sn_snd_alb%cldes ) == 'mixed oce-ice' .OR. TRIM ( sn_rcv_qsr%cldes ) == 'mixed oce-ice' ) THEN
683	CALL albedo_oce( zaos, zacs )
684	! Due to lack of information on nebulosity : mean clear/overcast sky
685	albedo_oce_mix(:,:) = ( zacs(:,:) + zaos(:,:) ) * 0.5
686	ENDIF
687
688	! ! ------------------------- !
689	! ! Ice fraction & Thickness !
690	! ! ------------------------- !
691	ssnd(jps_fice)%clname = 'OIceFrc'
692	ssnd(jps_hice)%clname = 'OIceTck'
693	ssnd(jps_hsnw)%clname = 'OSnwTck'
694	IF( k_ice /= 0 ) THEN
695	ssnd(jps_fice)%laction = .TRUE. ! if ice treated in the ocean (even in climato case)
696	! Currently no namelist entry to determine sending of multi-category ice fraction so use the thickness entry for now
697	IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_fice)%nct = jpl
698	ENDIF
699
700	SELECT CASE ( TRIM( sn_snd_thick%cldes ) )
701	CASE( 'none' ) ! nothing to do
702	CASE( 'ice and snow' )
703	ssnd(jps_hice:jps_hsnw)%laction = .TRUE.
704	IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) THEN
705	ssnd(jps_hice:jps_hsnw)%nct = jpl
706	ENDIF
707	CASE ( 'weighted ice and snow' )
708	ssnd(jps_hice:jps_hsnw)%laction = .TRUE.
709	IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_hice:jps_hsnw)%nct = jpl
710	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_thick%cldes' )
711	END SELECT
712
713	! ! ------------------------- !
714	! ! Surface current !
715	! ! ------------------------- !
716	! ocean currents ! ice velocities
717	ssnd(jps_ocx1)%clname = 'O_OCurx1' ; ssnd(jps_ivx1)%clname = 'O_IVelx1'
718	ssnd(jps_ocy1)%clname = 'O_OCury1' ; ssnd(jps_ivy1)%clname = 'O_IVely1'
719	ssnd(jps_ocz1)%clname = 'O_OCurz1' ; ssnd(jps_ivz1)%clname = 'O_IVelz1'
720	!
721	ssnd(jps_ocx1:jps_ivz1)%nsgn = -1. ! vectors: change of the sign at the north fold
722
723	IF( sn_snd_crt%clvgrd == 'U,V' ) THEN
724	ssnd(jps_ocx1)%clgrid = 'U' ; ssnd(jps_ocy1)%clgrid = 'V'
725	ELSE IF( sn_snd_crt%clvgrd /= 'T' ) THEN
726	CALL ctl_stop( 'sn_snd_crt%clvgrd must be equal to T' )
727	ssnd(jps_ocx1:jps_ivz1)%clgrid = 'T' ! all oce and ice components on the same unique grid
728	ENDIF
729	ssnd(jps_ocx1:jps_ivz1)%laction = .TRUE. ! default: all are send
730	IF( TRIM( sn_snd_crt%clvref ) == 'spherical' ) ssnd( (/jps_ocz1, jps_ivz1/) )%laction = .FALSE.
731	IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) ssnd(jps_ocx1:jps_ivz1)%nsgn = 1.
732	SELECT CASE( TRIM( sn_snd_crt%cldes ) )
733	CASE( 'none' ) ; ssnd(jps_ocx1:jps_ivz1)%laction = .FALSE.
734	CASE( 'oce only' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE.
735	CASE( 'weighted oce and ice' ) ! nothing to do
736	CASE( 'mixed oce-ice' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE.
737	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_crt%cldes' )
738	END SELECT
739
740	! ! ------------------------- !
741	! ! CO2 flux !
742	! ! ------------------------- !
743	ssnd(jps_co2)%clname = 'O_CO2FLX' ; IF( TRIM(sn_snd_co2%cldes) == 'coupled' ) ssnd(jps_co2 )%laction = .TRUE.
744
745	! ! ------------------------------- !
746	! ! OPA-SAS coupling - snd by opa !
747	! ! ------------------------------- !
748	ssnd(jps_ssh )%clname = 'O_SSHght'
749	ssnd(jps_soce )%clname = 'O_SSSal'
750	ssnd(jps_e3t1st)%clname = 'O_E3T1st'
751	ssnd(jps_fraqsr)%clname = 'O_FraQsr'
752	!
753	IF( nn_components == jp_iam_opa ) THEN
754	ssnd(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling
755	ssnd( (/jps_toce, jps_soce, jps_ssh, jps_fraqsr, jps_ocx1, jps_ocy1/) )%laction = .TRUE.
756	ssnd( jps_e3t1st )%laction = lk_vvl
757	! vector definition: not used but cleaner...
758	ssnd(jps_ocx1)%clgrid = 'U' ! oce components given at U-point
759	ssnd(jps_ocy1)%clgrid = 'V' ! and V-point
760	sn_snd_crt%clvgrd = 'U,V'
761	sn_snd_crt%clvor = 'local grid'
762	sn_snd_crt%clvref = 'spherical'
763	!
764	IF(lwp) THEN ! control print
765	WRITE(numout,*)
766	WRITE(numout,*)' sent fields to SAS component '
767	WRITE(numout,*)' sea surface temperature (T before, Celcius) '
768	WRITE(numout,*)' sea surface salinity '
769	WRITE(numout,*)' surface currents U,V on local grid and spherical coordinates'
770	WRITE(numout,*)' sea surface height '
771	WRITE(numout,*)' thickness of first ocean T level '
772	WRITE(numout,*)' fraction of solar net radiation absorbed in the first ocean level'
773	WRITE(numout,*)
774	ENDIF
775	ENDIF
776	! ! ------------------------------- !
777	! ! OPA-SAS coupling - snd by sas !
778	! ! ------------------------------- !
779	ssnd(jps_sflx )%clname = 'I_SFLX'
780	ssnd(jps_fice2 )%clname = 'IIceFrc'
781	ssnd(jps_qsroce)%clname = 'I_QsrOce'
782	ssnd(jps_qnsoce)%clname = 'I_QnsOce'
783	ssnd(jps_oemp )%clname = 'IOEvaMPr'
784	ssnd(jps_otx1 )%clname = 'I_OTaux1'
785	ssnd(jps_oty1 )%clname = 'I_OTauy1'
786	ssnd(jps_rnf )%clname = 'I_Runoff'
787	ssnd(jps_taum )%clname = 'I_TauMod'
788	!
789	IF( nn_components == jp_iam_sas ) THEN
790	IF( .NOT. ln_cpl ) ssnd(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling
791	ssnd( (/jps_qsroce, jps_qnsoce, jps_oemp, jps_fice2, jps_sflx, jps_otx1, jps_oty1, jps_taum/) )%laction = .TRUE.
792	!
793	! Change first letter to couple with atmosphere if already coupled with sea_ice
794	! this is nedeed as each variable name used in the namcouple must be unique:
795	! for example O_SSTSST sent by OPA to SAS and therefore S_SSTSST sent by SAS to the Atmosphere
796	DO jn = 1, jpsnd
797	IF ( ssnd(jn)%clname(1:1) == "O" ) ssnd(jn)%clname = "S"//ssnd(jn)%clname(2:LEN(ssnd(jn)%clname))
798	END DO
799	!
800	IF(lwp) THEN ! control print
801	WRITE(numout,*)
802	IF( .NOT. ln_cpl ) THEN
803	WRITE(numout,*)' sent fields to OPA component '
804	ELSE
805	WRITE(numout,*)' Additional sent fields to OPA component : '
806	ENDIF
807	WRITE(numout,*)' ice cover '
808	WRITE(numout,*)' oce only EMP '
809	WRITE(numout,*)' salt flux '
810	WRITE(numout,*)' mixed oce-ice solar flux '
811	WRITE(numout,*)' mixed oce-ice non solar flux '
812	WRITE(numout,*)' wind stress U,V components'
813	WRITE(numout,*)' wind stress module'
814	ENDIF
815	ENDIF
816
817	!
818	! ================================ !
819	! initialisation of the coupler !
820	! ================================ !
821
822	CALL cpl_define(jprcv, jpsnd, nn_cplmodel)
823
824	IF (ln_usecplmask) THEN
825	xcplmask(:,:,:) = 0.
826	CALL iom_open( 'cplmask', inum )
827	CALL iom_get( inum, jpdom_unknown, 'cplmask', xcplmask(1:nlci,1:nlcj,1:nn_cplmodel), &
828	& kstart = (/ mig(1),mjg(1),1 /), kcount = (/ nlci,nlcj,nn_cplmodel /) )
829	CALL iom_close( inum )
830	ELSE
831	xcplmask(:,:,:) = 1.
832	ENDIF
833	xcplmask(:,:,0) = 1. - SUM( xcplmask(:,:,1:nn_cplmodel), dim = 3 )
834	!
835	ncpl_qsr_freq = cpl_freq( 'O_QsrOce' ) + cpl_freq( 'O_QsrMix' ) + cpl_freq( 'I_QsrOce' ) + cpl_freq( 'I_QsrMix' )
836	IF( ln_dm2dc .AND. ln_cpl .AND. ncpl_qsr_freq /= 86400 ) &
837	& CALL ctl_stop( 'sbc_cpl_init: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' )
838	ncpl_qsr_freq = 86400 / ncpl_qsr_freq
839
840	IF( ln_coupled_iceshelf_fluxes ) THEN
841	! Crude masks to separate the Antarctic and Greenland icesheets. Obviously something
842	! more complicated could be done if required.
843	greenland_icesheet_mask = 0.0
844	WHERE( gphit >= 0.0 ) greenland_icesheet_mask = 1.0
845	antarctica_icesheet_mask = 0.0
846	WHERE( gphit < 0.0 ) antarctica_icesheet_mask = 1.0
847
848	! initialise other variables
849	greenland_icesheet_mass_array(:,:) = 0.0
850	antarctica_icesheet_mass_array(:,:) = 0.0
851
852	IF( .not. ln_rstart ) THEN
853	greenland_icesheet_mass = 0.0
854	greenland_icesheet_mass_rate_of_change = 0.0
855	greenland_icesheet_timelapsed = 0.0
856	antarctica_icesheet_mass = 0.0
857	antarctica_icesheet_mass_rate_of_change = 0.0
858	antarctica_icesheet_timelapsed = 0.0
859	ENDIF
860
861	ENDIF
862
863	CALL wrk_dealloc( jpi,jpj, zacs, zaos )
864	!
865	IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_init')
866	!
867	END SUBROUTINE sbc_cpl_init
868
869
870	SUBROUTINE sbc_cpl_rcv( kt, k_fsbc, k_ice )
871	!!----------------------------------------------------------------------
872	!! * ROUTINE sbc_cpl_rcv *
873	!!
874	!! ** Purpose : provide the stress over the ocean and, if no sea-ice,
875	!! provide the ocean heat and freshwater fluxes.
876	!!
877	!! ** Method : - Receive all the atmospheric fields (stored in frcv array). called at each time step.
878	!! OASIS controls if there is something do receive or not. nrcvinfo contains the info
879	!! to know if the field was really received or not
880	!!
881	!! --> If ocean stress was really received:
882	!!
883	!! - transform the received ocean stress vector from the received
884	!! referential and grid into an atmosphere-ocean stress in
885	!! the (i,j) ocean referencial and at the ocean velocity point.
886	!! The received stress are :
887	!! - defined by 3 components (if cartesian coordinate)
888	!! or by 2 components (if spherical)
889	!! - oriented along geographical coordinate (if eastward-northward)
890	!! or along the local grid coordinate (if local grid)
891	!! - given at U- and V-point, resp. if received on 2 grids
892	!! or at T-point if received on 1 grid
893	!! Therefore and if necessary, they are successively
894	!! processed in order to obtain them
895	!! first as 2 components on the sphere
896	!! second as 2 components oriented along the local grid
897	!! third as 2 components on the U,V grid
898	!!
899	!! -->
900	!!
901	!! - In 'ocean only' case, non solar and solar ocean heat fluxes
902	!! and total ocean freshwater fluxes
903	!!
904	!! ** Method : receive all fields from the atmosphere and transform
905	!! them into ocean surface boundary condition fields
906	!!
907	!! ** Action : update utau, vtau ocean stress at U,V grid
908	!! taum wind stress module at T-point
909	!! wndm wind speed module at T-point over free ocean or leads in presence of sea-ice
910	!! qns non solar heat fluxes including emp heat content (ocean only case)
911	!! and the latent heat flux of solid precip. melting
912	!! qsr solar ocean heat fluxes (ocean only case)
913	!! emp upward mass flux [evap. - precip. (- runoffs) (- calving)] (ocean only case)
914	!!----------------------------------------------------------------------
915	INTEGER, INTENT(in) :: kt ! ocean model time step index
916	INTEGER, INTENT(in) :: k_fsbc ! frequency of sbc (-> ice model) computation
917	INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3)
918
919	!!
920	LOGICAL :: llnewtx, llnewtau ! update wind stress components and module??
921	INTEGER :: ji, jj, jn ! dummy loop indices
922	INTEGER :: isec ! number of seconds since nit000 (assuming rdttra did not change since nit000)
923	INTEGER :: ikchoix
924	REAL(wp) :: zcumulneg, zcumulpos ! temporary scalars
925	REAL(wp) :: zgreenland_icesheet_mass_in, zantarctica_icesheet_mass_in
926	REAL(wp) :: zgreenland_icesheet_mass_b, zantarctica_icesheet_mass_b
927	REAL(wp) :: zmask_sum, zepsilon
928	REAL(wp) :: zcoef ! temporary scalar
929	REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3
930	REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient
931	REAL(wp) :: zzx, zzy ! temporary variables
932	REAL(wp), POINTER, DIMENSION(:,:) :: ztx, zty, zmsk, zemp, zqns, zqsr, ztx2, zty2
933	!!----------------------------------------------------------------------
934
935	! RSRH temporary arrays for testing, just to recieve incoming MEDUSA related fields
936	! until we know where they need to go.
937	REAL(wp), ALLOCATABLE :: atm_pco2(:,:)
938	REAL(wp), ALLOCATABLE :: atm_dust(:,:)
939
940	!
941	IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_rcv')
942	!
943	CALL wrk_alloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr, ztx2, zty2 )
944	!
945	IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0)
946	!
947	! ! ======================================================= !
948	! ! Receive all the atmos. fields (including ice information)
949	! ! ======================================================= !
950	isec = ( kt - nit000 ) * NINT( rdttra(1) ) ! date of exchanges
951	DO jn = 1, jprcv ! received fields sent by the atmosphere
952	IF( srcv(jn)%laction ) CALL cpl_rcv( jn, isec, frcv(jn)%z3, xcplmask(:,:,1:nn_cplmodel), nrcvinfo(jn) )
953	END DO
954
955	! ! ========================= !
956	IF( srcv(jpr_otx1)%laction ) THEN ! ocean stress components !
957	! ! ========================= !
958	! define frcv(jpr_otx1)%z3(:,:,1) and frcv(jpr_oty1)%z3(:,:,1): stress at U/V point along model grid
959	! => need to be done only when we receive the field
960	IF( nrcvinfo(jpr_otx1) == OASIS_Rcv ) THEN
961	!
962	IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere
963	! ! (cartesian to spherical -> 3 to 2 components)
964	!
965	CALL geo2oce( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), frcv(jpr_otz1)%z3(:,:,1), &
966	& srcv(jpr_otx1)%clgrid, ztx, zty )
967	frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid
968	frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid
969	!
970	IF( srcv(jpr_otx2)%laction ) THEN
971	CALL geo2oce( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), frcv(jpr_otz2)%z3(:,:,1), &
972	& srcv(jpr_otx2)%clgrid, ztx, zty )
973	frcv(jpr_otx2)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid
974	frcv(jpr_oty2)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 2nd grid
975	ENDIF
976	!
977	ENDIF
978	!
979	IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid
980	! ! (geographical to local grid -> rotate the components)
981	IF( srcv(jpr_otx1)%clgrid == 'U' .AND. (.NOT. srcv(jpr_otx2)%laction) ) THEN
982	! Temporary code for HadGEM3 - will be removed eventually.
983	! Only applies when we have only taux on U grid and tauy on V grid
984	DO jj=2,jpjm1
985	DO ji=2,jpim1
986	ztx(ji,jj)=0.25*vmask(ji,jj,1) &
987	*(frcv(jpr_otx1)%z3(ji,jj,1)+frcv(jpr_otx1)%z3(ji-1,jj,1) &
988	+frcv(jpr_otx1)%z3(ji,jj+1,1)+frcv(jpr_otx1)%z3(ji-1,jj+1,1))
989	zty(ji,jj)=0.25*umask(ji,jj,1) &
990	*(frcv(jpr_oty1)%z3(ji,jj,1)+frcv(jpr_oty1)%z3(ji+1,jj,1) &
991	+frcv(jpr_oty1)%z3(ji,jj-1,1)+frcv(jpr_oty1)%z3(ji+1,jj-1,1))
992	ENDDO
993	ENDDO
994
995	ikchoix = 1
996	CALL repcmo (frcv(jpr_otx1)%z3(:,:,1),zty,ztx,frcv(jpr_oty1)%z3(:,:,1),ztx2,zty2,ikchoix)
997	CALL lbc_lnk (ztx2,'U', -1. )
998	CALL lbc_lnk (zty2,'V', -1. )
999	frcv(jpr_otx1)%z3(:,:,1)=ztx2(:,:)
1000	frcv(jpr_oty1)%z3(:,:,1)=zty2(:,:)
1001	ELSE
1002	CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx )
1003	frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid
1004	IF( srcv(jpr_otx2)%laction ) THEN
1005	CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty )
1006	ELSE
1007	CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty )
1008	ENDIF
1009	frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 2nd grid
1010	ENDIF
1011	ENDIF
1012	!
1013	IF( srcv(jpr_otx1)%clgrid == 'T' ) THEN
1014	DO jj = 2, jpjm1 ! T ==> (U,V)
1015	DO ji = fs_2, fs_jpim1 ! vector opt.
1016	frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) )
1017	frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) )
1018	END DO
1019	END DO
1020	CALL lbc_lnk( frcv(jpr_otx1)%z3(:,:,1), 'U', -1. ) ; CALL lbc_lnk( frcv(jpr_oty1)%z3(:,:,1), 'V', -1. )
1021	ENDIF
1022	llnewtx = .TRUE.
1023	ELSE
1024	llnewtx = .FALSE.
1025	ENDIF
1026	! ! ========================= !
1027	ELSE ! No dynamical coupling !
1028	! ! ========================= !
1029	frcv(jpr_otx1)%z3(:,:,1) = 0.e0 ! here simply set to zero
1030	frcv(jpr_oty1)%z3(:,:,1) = 0.e0 ! an external read in a file can be added instead
1031	llnewtx = .TRUE.
1032	!
1033	ENDIF
1034	! ! ========================= !
1035	! ! wind stress module ! (taum)
1036	! ! ========================= !
1037	!
1038	IF( .NOT. srcv(jpr_taum)%laction ) THEN ! compute wind stress module from its components if not received
1039	! => need to be done only when otx1 was changed
1040	IF( llnewtx ) THEN
1041	!CDIR NOVERRCHK
1042	DO jj = 2, jpjm1
1043	!CDIR NOVERRCHK
1044	DO ji = fs_2, fs_jpim1 ! vect. opt.
1045	zzx = frcv(jpr_otx1)%z3(ji-1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1)
1046	zzy = frcv(jpr_oty1)%z3(ji ,jj-1,1) + frcv(jpr_oty1)%z3(ji,jj,1)
1047	frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy )
1048	END DO
1049	END DO
1050	CALL lbc_lnk( frcv(jpr_taum)%z3(:,:,1), 'T', 1. )
1051	llnewtau = .TRUE.
1052	ELSE
1053	llnewtau = .FALSE.
1054	ENDIF
1055	ELSE
1056	llnewtau = nrcvinfo(jpr_taum) == OASIS_Rcv
1057	! Stress module can be negative when received (interpolation problem)
1058	IF( llnewtau ) THEN
1059	frcv(jpr_taum)%z3(:,:,1) = MAX( 0._wp, frcv(jpr_taum)%z3(:,:,1) )
1060	ENDIF
1061	ENDIF
1062	!
1063	! ! ========================= !
1064	! ! 10 m wind speed ! (wndm)
1065	! ! ========================= !
1066	!
1067	IF( .NOT. srcv(jpr_w10m)%laction ) THEN ! compute wind spreed from wind stress module if not received
1068	! => need to be done only when taumod was changed
1069	IF( llnewtau ) THEN
1070	zcoef = 1. / ( zrhoa * zcdrag )
1071	!CDIR NOVERRCHK
1072	DO jj = 1, jpj
1073	!CDIR NOVERRCHK
1074	DO ji = 1, jpi
1075	frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef )
1076	END DO
1077	END DO
1078	ENDIF
1079	ENDIF
1080
1081	! u(v)tau and taum will be modified by ice model
1082	! -> need to be reset before each call of the ice/fsbc
1083	IF( MOD( kt-1, k_fsbc ) == 0 ) THEN
1084	!
1085	IF( ln_mixcpl ) THEN
1086	utau(:,:) = utau(:,:) * xcplmask(:,:,0) + frcv(jpr_otx1)%z3(:,:,1) * zmsk(:,:)
1087	vtau(:,:) = vtau(:,:) * xcplmask(:,:,0) + frcv(jpr_oty1)%z3(:,:,1) * zmsk(:,:)
1088	taum(:,:) = taum(:,:) * xcplmask(:,:,0) + frcv(jpr_taum)%z3(:,:,1) * zmsk(:,:)
1089	wndm(:,:) = wndm(:,:) * xcplmask(:,:,0) + frcv(jpr_w10m)%z3(:,:,1) * zmsk(:,:)
1090	ELSE
1091	utau(:,:) = frcv(jpr_otx1)%z3(:,:,1)
1092	vtau(:,:) = frcv(jpr_oty1)%z3(:,:,1)
1093	taum(:,:) = frcv(jpr_taum)%z3(:,:,1)
1094	wndm(:,:) = frcv(jpr_w10m)%z3(:,:,1)
1095	ENDIF
1096	CALL iom_put( "taum_oce", taum ) ! output wind stress module
1097	!
1098	ENDIF
1099
1100	#if defined key_cpl_carbon_cycle
1101	! ! ================== !
1102	! ! atmosph. CO2 (ppm) !
1103	! ! ================== !
1104	IF( srcv(jpr_co2)%laction ) atm_co2(:,:) = frcv(jpr_co2)%z3(:,:,1)
1105	#endif
1106
1107	#if defined key_medusa
1108	! RSRH Allocate temporary arrays to receive incoming fields during testing
1109	ALLOCATE(atm_pco2(jpi,jpj))
1110	ALLOCATE(atm_dust(jpi,jpj))
1111
1112	IF( srcv(jpr_atm_pco2)%laction) atm_pco2(:,:) = frcv(jpr_atm_pco2)%z3(:,:,1)
1113	IF( srcv(jpr_atm_dust)%laction) atm_dust(:,:) = frcv(jpr_atm_dust)%z3(:,:,1)
1114
1115	! RSRH Deallocate temporary arrays.
1116	DEALLOCATE(atm_pco2)
1117	DEALLOCATE(atm_dust)
1118	#endif
1119
1120
1121
1122
1123	! Fields received by SAS when OASIS coupling
1124	! (arrays no more filled at sbcssm stage)
1125	! ! ================== !
1126	! ! SSS !
1127	! ! ================== !
1128	IF( srcv(jpr_soce)%laction ) THEN ! received by sas in case of opa <-> sas coupling
1129	sss_m(:,:) = frcv(jpr_soce)%z3(:,:,1)
1130	CALL iom_put( 'sss_m', sss_m )
1131	ENDIF
1132	!
1133	! ! ================== !
1134	! ! SST !
1135	! ! ================== !
1136	IF( srcv(jpr_toce)%laction ) THEN ! received by sas in case of opa <-> sas coupling
1137	sst_m(:,:) = frcv(jpr_toce)%z3(:,:,1)
1138	IF( srcv(jpr_soce)%laction .AND. ln_useCT ) THEN ! make sure that sst_m is the potential temperature
1139	sst_m(:,:) = eos_pt_from_ct( sst_m(:,:), sss_m(:,:) )
1140	ENDIF
1141	ENDIF
1142	! ! ================== !
1143	! ! SSH !
1144	! ! ================== !
1145	IF( srcv(jpr_ssh )%laction ) THEN ! received by sas in case of opa <-> sas coupling
1146	ssh_m(:,:) = frcv(jpr_ssh )%z3(:,:,1)
1147	CALL iom_put( 'ssh_m', ssh_m )
1148	ENDIF
1149	! ! ================== !
1150	! ! surface currents !
1151	! ! ================== !
1152	IF( srcv(jpr_ocx1)%laction ) THEN ! received by sas in case of opa <-> sas coupling
1153	ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1)
1154	ub (:,:,1) = ssu_m(:,:) ! will be used in sbcice_lim in the call of lim_sbc_tau
1155	CALL iom_put( 'ssu_m', ssu_m )
1156	ENDIF
1157	IF( srcv(jpr_ocy1)%laction ) THEN
1158	ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1)
1159	vb (:,:,1) = ssv_m(:,:) ! will be used in sbcice_lim in the call of lim_sbc_tau
1160	CALL iom_put( 'ssv_m', ssv_m )
1161	ENDIF
1162	! ! ======================== !
1163	! ! first T level thickness !
1164	! ! ======================== !
1165	IF( srcv(jpr_e3t1st )%laction ) THEN ! received by sas in case of opa <-> sas coupling
1166	e3t_m(:,:) = frcv(jpr_e3t1st )%z3(:,:,1)
1167	CALL iom_put( 'e3t_m', e3t_m(:,:) )
1168	ENDIF
1169	! ! ================================ !
1170	! ! fraction of solar net radiation !
1171	! ! ================================ !
1172	IF( srcv(jpr_fraqsr)%laction ) THEN ! received by sas in case of opa <-> sas coupling
1173	frq_m(:,:) = frcv(jpr_fraqsr)%z3(:,:,1)
1174	CALL iom_put( 'frq_m', frq_m )
1175	ENDIF
1176
1177	! ! ========================= !
1178	IF( k_ice <= 1 .AND. MOD( kt-1, k_fsbc ) == 0 ) THEN ! heat & freshwater fluxes ! (Ocean only case)
1179	! ! ========================= !
1180	!
1181	! ! total freshwater fluxes over the ocean (emp)
1182	IF( srcv(jpr_oemp)%laction .OR. srcv(jpr_rain)%laction ) THEN
1183	SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) ! evaporation - precipitation
1184	CASE( 'conservative' )
1185	zemp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ( frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1) )
1186	CASE( 'oce only', 'oce and ice' )
1187	zemp(:,:) = frcv(jpr_oemp)%z3(:,:,1)
1188	CASE default
1189	CALL ctl_stop( 'sbc_cpl_rcv: wrong definition of sn_rcv_emp%cldes' )
1190	END SELECT
1191	ELSE
1192	zemp(:,:) = 0._wp
1193	ENDIF
1194	!
1195	! ! runoffs and calving (added in emp)
1196	IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1)
1197	IF( srcv(jpr_cal)%laction ) zemp(:,:) = zemp(:,:) - frcv(jpr_cal)%z3(:,:,1)
1198
1199	IF( ln_mixcpl ) THEN ; emp(:,:) = emp(:,:) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:)
1200	ELSE ; emp(:,:) = zemp(:,:)
1201	ENDIF
1202	!
1203	! ! non solar heat flux over the ocean (qns)
1204	IF( srcv(jpr_qnsoce)%laction ) THEN ; zqns(:,:) = frcv(jpr_qnsoce)%z3(:,:,1)
1205	ELSE IF( srcv(jpr_qnsmix)%laction ) THEN ; zqns(:,:) = frcv(jpr_qnsmix)%z3(:,:,1)
1206	ELSE ; zqns(:,:) = 0._wp
1207	END IF
1208	! update qns over the free ocean with:
1209	IF( nn_components /= jp_iam_opa ) THEN
1210	zqns(:,:) = zqns(:,:) - zemp(:,:) * sst_m(:,:) * rcp ! remove heat content due to mass flux (assumed to be at SST)
1211	IF( srcv(jpr_snow )%laction ) THEN
1212	zqns(:,:) = zqns(:,:) - frcv(jpr_snow)%z3(:,:,1) * lfus ! energy for melting solid precipitation over the free ocean
1213	ENDIF
1214	ENDIF
1215	IF( ln_mixcpl ) THEN ; qns(:,:) = qns(:,:) * xcplmask(:,:,0) + zqns(:,:) * zmsk(:,:)
1216	ELSE ; qns(:,:) = zqns(:,:)
1217	ENDIF
1218
1219	! ! solar flux over the ocean (qsr)
1220	IF ( srcv(jpr_qsroce)%laction ) THEN ; zqsr(:,:) = frcv(jpr_qsroce)%z3(:,:,1)
1221	ELSE IF( srcv(jpr_qsrmix)%laction ) then ; zqsr(:,:) = frcv(jpr_qsrmix)%z3(:,:,1)
1222	ELSE ; zqsr(:,:) = 0._wp
1223	ENDIF
1224	IF( ln_dm2dc .AND. ln_cpl ) zqsr(:,:) = sbc_dcy( zqsr ) ! modify qsr to include the diurnal cycle
1225	IF( ln_mixcpl ) THEN ; qsr(:,:) = qsr(:,:) * xcplmask(:,:,0) + zqsr(:,:) * zmsk(:,:)
1226	ELSE ; qsr(:,:) = zqsr(:,:)
1227	ENDIF
1228	!
1229	! salt flux over the ocean (received by opa in case of opa <-> sas coupling)
1230	IF( srcv(jpr_sflx )%laction ) sfx(:,:) = frcv(jpr_sflx )%z3(:,:,1)
1231	! Ice cover (received by opa in case of opa <-> sas coupling)
1232	IF( srcv(jpr_fice )%laction ) fr_i(:,:) = frcv(jpr_fice )%z3(:,:,1)
1233	!
1234
1235	ENDIF
1236
1237	! ! land ice masses : Greenland
1238	zepsilon = rn_iceshelf_fluxes_tolerance
1239
1240	IF( srcv(jpr_grnm)%laction ) THEN
1241	greenland_icesheet_mass_array(:,:) = frcv(jpr_grnm)%z3(:,:,1)
1242	! take average over ocean points of input array to avoid cumulative error over time
1243	zgreenland_icesheet_mass_in = SUM( greenland_icesheet_mass_array(:,:) * tmask(:,:,1) )
1244	IF(lk_mpp) CALL mpp_sum( zgreenland_icesheet_mass_in )
1245	zmask_sum = SUM( tmask(:,:,1) )
1246	IF(lk_mpp) CALL mpp_sum( zmask_sum )
1247	zgreenland_icesheet_mass_in = zgreenland_icesheet_mass_in / zmask_sum
1248	greenland_icesheet_timelapsed = greenland_icesheet_timelapsed + rdt
1249	IF( ABS( zgreenland_icesheet_mass_in - greenland_icesheet_mass ) > zepsilon ) THEN
1250	zgreenland_icesheet_mass_b = greenland_icesheet_mass
1251
1252	! Only update the mass if it has increased
1253	IF ( (zgreenland_icesheet_mass_in - greenland_icesheet_mass) > 0.0 ) THEN
1254	greenland_icesheet_mass = zgreenland_icesheet_mass_in
1255	ENDIF
1256
1257	IF( zgreenland_icesheet_mass_b /= 0.0 ) &
1258	& greenland_icesheet_mass_rate_of_change = ( greenland_icesheet_mass - zgreenland_icesheet_mass_b ) / greenland_icesheet_timelapsed
1259	greenland_icesheet_timelapsed = 0.0_wp
1260	ENDIF
1261	IF(lwp) WRITE(numout,*) 'Greenland icesheet mass (kg) read in is ', zgreenland_icesheet_mass_in
1262	IF(lwp) WRITE(numout,*) 'Greenland icesheet mass (kg) used is ', greenland_icesheet_mass
1263	IF(lwp) WRITE(numout,*) 'Greenland icesheet mass rate of change (kg/s) is ', greenland_icesheet_mass_rate_of_change
1264	IF(lwp) WRITE(numout,*) 'Greenland icesheet seconds lapsed since last change is ', greenland_icesheet_timelapsed
1265	ENDIF
1266
1267	! ! land ice masses : Antarctica
1268	IF( srcv(jpr_antm)%laction ) THEN
1269	antarctica_icesheet_mass_array(:,:) = frcv(jpr_antm)%z3(:,:,1)
1270	! take average over ocean points of input array to avoid cumulative error from rounding errors over time
1271	zantarctica_icesheet_mass_in = SUM( antarctica_icesheet_mass_array(:,:) * tmask(:,:,1) )
1272	IF(lk_mpp) CALL mpp_sum( zantarctica_icesheet_mass_in )
1273	zmask_sum = SUM( tmask(:,:,1) )
1274	IF(lk_mpp) CALL mpp_sum( zmask_sum )
1275	zantarctica_icesheet_mass_in = zantarctica_icesheet_mass_in / zmask_sum
1276	antarctica_icesheet_timelapsed = antarctica_icesheet_timelapsed + rdt
1277	IF( ABS( zantarctica_icesheet_mass_in - antarctica_icesheet_mass ) > zepsilon ) THEN
1278	zantarctica_icesheet_mass_b = antarctica_icesheet_mass
1279
1280	! Only update the mass if it has increased
1281	IF ( (zantarctica_icesheet_mass_in - antarctica_icesheet_mass) > 0.0 ) THEN
1282	antarctica_icesheet_mass = zantarctica_icesheet_mass_in
1283	END IF
1284
1285	IF( zantarctica_icesheet_mass_b /= 0.0 ) &
1286	& antarctica_icesheet_mass_rate_of_change = ( antarctica_icesheet_mass - zantarctica_icesheet_mass_b ) / antarctica_icesheet_timelapsed
1287	antarctica_icesheet_timelapsed = 0.0_wp
1288	ENDIF
1289	IF(lwp) WRITE(numout,*) 'Antarctica icesheet mass (kg) read in is ', zantarctica_icesheet_mass_in
1290	IF(lwp) WRITE(numout,*) 'Antarctica icesheet mass (kg) used is ', antarctica_icesheet_mass
1291	IF(lwp) WRITE(numout,*) 'Antarctica icesheet mass rate of change (kg/s) is ', antarctica_icesheet_mass_rate_of_change
1292	IF(lwp) WRITE(numout,*) 'Antarctica icesheet seconds lapsed since last change is ', antarctica_icesheet_timelapsed
1293	ENDIF
1294
1295	!
1296	CALL wrk_dealloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr, ztx2, zty2 )
1297	!
1298	IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_rcv')
1299	!
1300	END SUBROUTINE sbc_cpl_rcv
1301
1302
1303	SUBROUTINE sbc_cpl_ice_tau( p_taui, p_tauj )
1304	!!----------------------------------------------------------------------
1305	!! * ROUTINE sbc_cpl_ice_tau *
1306	!!
1307	!! ** Purpose : provide the stress over sea-ice in coupled mode
1308	!!
1309	!! ** Method : transform the received stress from the atmosphere into
1310	!! an atmosphere-ice stress in the (i,j) ocean referencial
1311	!! and at the velocity point of the sea-ice model (cp_ice_msh):
1312	!! 'C'-grid : i- (j-) components given at U- (V-) point
1313	!! 'I'-grid : B-grid lower-left corner: both components given at I-point
1314	!!
1315	!! The received stress are :
1316	!! - defined by 3 components (if cartesian coordinate)
1317	!! or by 2 components (if spherical)
1318	!! - oriented along geographical coordinate (if eastward-northward)
1319	!! or along the local grid coordinate (if local grid)
1320	!! - given at U- and V-point, resp. if received on 2 grids
1321	!! or at a same point (T or I) if received on 1 grid
1322	!! Therefore and if necessary, they are successively
1323	!! processed in order to obtain them
1324	!! first as 2 components on the sphere
1325	!! second as 2 components oriented along the local grid
1326	!! third as 2 components on the cp_ice_msh point
1327	!!
1328	!! Except in 'oce and ice' case, only one vector stress field
1329	!! is received. It has already been processed in sbc_cpl_rcv
1330	!! so that it is now defined as (i,j) components given at U-
1331	!! and V-points, respectively. Therefore, only the third
1332	!! transformation is done and only if the ice-grid is a 'I'-grid.
1333	!!
1334	!! ** Action : return ptau_i, ptau_j, the stress over the ice at cp_ice_msh point
1335	!!----------------------------------------------------------------------
1336	REAL(wp), INTENT(out), DIMENSION(:,:) :: p_taui ! i- & j-components of atmos-ice stress [N/m2]
1337	REAL(wp), INTENT(out), DIMENSION(:,:) :: p_tauj ! at I-point (B-grid) or U & V-point (C-grid)
1338	!!
1339	INTEGER :: ji, jj ! dummy loop indices
1340	INTEGER :: itx ! index of taux over ice
1341	REAL(wp), POINTER, DIMENSION(:,:) :: ztx, zty
1342	!!----------------------------------------------------------------------
1343	!
1344	IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_ice_tau')
1345	!
1346	CALL wrk_alloc( jpi,jpj, ztx, zty )
1347
1348	IF( srcv(jpr_itx1)%laction ) THEN ; itx = jpr_itx1
1349	ELSE ; itx = jpr_otx1
1350	ENDIF
1351
1352	! do something only if we just received the stress from atmosphere
1353	IF( nrcvinfo(itx) == OASIS_Rcv ) THEN
1354
1355	! ! ======================= !
1356	IF( srcv(jpr_itx1)%laction ) THEN ! ice stress received !
1357	! ! ======================= !
1358	!
1359	IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere
1360	! ! (cartesian to spherical -> 3 to 2 components)
1361	CALL geo2oce( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), frcv(jpr_itz1)%z3(:,:,1), &
1362	& srcv(jpr_itx1)%clgrid, ztx, zty )
1363	frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid
1364	frcv(jpr_ity1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid
1365	!
1366	IF( srcv(jpr_itx2)%laction ) THEN
1367	CALL geo2oce( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), frcv(jpr_itz2)%z3(:,:,1), &
1368	& srcv(jpr_itx2)%clgrid, ztx, zty )
1369	frcv(jpr_itx2)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid
1370	frcv(jpr_ity2)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 2nd grid
1371	ENDIF
1372	!
1373	ENDIF
1374	!
1375	IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid
1376	! ! (geographical to local grid -> rotate the components)
1377	CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->i', ztx )
1378	IF( srcv(jpr_itx2)%laction ) THEN
1379	CALL rot_rep( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), srcv(jpr_itx2)%clgrid, 'en->j', zty )
1380	ELSE
1381	CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->j', zty )
1382	ENDIF
1383	frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid
1384	frcv(jpr_ity1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 1st grid
1385	ENDIF
1386	! ! ======================= !
1387	ELSE ! use ocean stress !
1388	! ! ======================= !
1389	frcv(jpr_itx1)%z3(:,:,1) = frcv(jpr_otx1)%z3(:,:,1)
1390	frcv(jpr_ity1)%z3(:,:,1) = frcv(jpr_oty1)%z3(:,:,1)
1391	!
1392	ENDIF
1393	! ! ======================= !
1394	! ! put on ice grid !
1395	! ! ======================= !
1396	!
1397	! j+1 j -----V---F
1398	! ice stress on ice velocity point (cp_ice_msh) ! \|
1399	! (C-grid ==>(U,V) or B-grid ==> I or F) j \| T U
1400	! \| \|
1401	! j j-1 -I-------\|
1402	! (for I) \| \|
1403	! i-1 i i
1404	! i i+1 (for I)
1405	SELECT CASE ( cp_ice_msh )
1406	!
1407	CASE( 'I' ) ! B-grid ==> I
1408	SELECT CASE ( srcv(jpr_itx1)%clgrid )
1409	CASE( 'U' )
1410	DO jj = 2, jpjm1 ! (U,V) ==> I
1411	DO ji = 2, jpim1 ! NO vector opt.
1412	p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji-1,jj ,1) + frcv(jpr_itx1)%z3(ji-1,jj-1,1) )
1413	p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji ,jj-1,1) + frcv(jpr_ity1)%z3(ji-1,jj-1,1) )
1414	END DO
1415	END DO
1416	CASE( 'F' )
1417	DO jj = 2, jpjm1 ! F ==> I
1418	DO ji = 2, jpim1 ! NO vector opt.
1419	p_taui(ji,jj) = frcv(jpr_itx1)%z3(ji-1,jj-1,1)
1420	p_tauj(ji,jj) = frcv(jpr_ity1)%z3(ji-1,jj-1,1)
1421	END DO
1422	END DO
1423	CASE( 'T' )
1424	DO jj = 2, jpjm1 ! T ==> I
1425	DO ji = 2, jpim1 ! NO vector opt.
1426	p_taui(ji,jj) = 0.25 * ( frcv(jpr_itx1)%z3(ji,jj ,1) + frcv(jpr_itx1)%z3(ji-1,jj ,1) &
1427	& + frcv(jpr_itx1)%z3(ji,jj-1,1) + frcv(jpr_itx1)%z3(ji-1,jj-1,1) )
1428	p_tauj(ji,jj) = 0.25 * ( frcv(jpr_ity1)%z3(ji,jj ,1) + frcv(jpr_ity1)%z3(ji-1,jj ,1) &
1429	& + frcv(jpr_oty1)%z3(ji,jj-1,1) + frcv(jpr_ity1)%z3(ji-1,jj-1,1) )
1430	END DO
1431	END DO
1432	CASE( 'I' )
1433	p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1) ! I ==> I
1434	p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1)
1435	END SELECT
1436	IF( srcv(jpr_itx1)%clgrid /= 'I' ) THEN
1437	CALL lbc_lnk( p_taui, 'I', -1. ) ; CALL lbc_lnk( p_tauj, 'I', -1. )
1438	ENDIF
1439	!
1440	CASE( 'F' ) ! B-grid ==> F
1441	SELECT CASE ( srcv(jpr_itx1)%clgrid )
1442	CASE( 'U' )
1443	DO jj = 2, jpjm1 ! (U,V) ==> F
1444	DO ji = fs_2, fs_jpim1 ! vector opt.
1445	p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji,jj,1) + frcv(jpr_itx1)%z3(ji ,jj+1,1) )
1446	p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji,jj,1) + frcv(jpr_ity1)%z3(ji+1,jj ,1) )
1447	END DO
1448	END DO
1449	CASE( 'I' )
1450	DO jj = 2, jpjm1 ! I ==> F
1451	DO ji = 2, jpim1 ! NO vector opt.
1452	p_taui(ji,jj) = frcv(jpr_itx1)%z3(ji+1,jj+1,1)
1453	p_tauj(ji,jj) = frcv(jpr_ity1)%z3(ji+1,jj+1,1)
1454	END DO
1455	END DO
1456	CASE( 'T' )
1457	DO jj = 2, jpjm1 ! T ==> F
1458	DO ji = 2, jpim1 ! NO vector opt.
1459	p_taui(ji,jj) = 0.25 * ( frcv(jpr_itx1)%z3(ji,jj ,1) + frcv(jpr_itx1)%z3(ji+1,jj ,1) &
1460	& + frcv(jpr_itx1)%z3(ji,jj+1,1) + frcv(jpr_itx1)%z3(ji+1,jj+1,1) )
1461	p_tauj(ji,jj) = 0.25 * ( frcv(jpr_ity1)%z3(ji,jj ,1) + frcv(jpr_ity1)%z3(ji+1,jj ,1) &
1462	& + frcv(jpr_ity1)%z3(ji,jj+1,1) + frcv(jpr_ity1)%z3(ji+1,jj+1,1) )
1463	END DO
1464	END DO
1465	CASE( 'F' )
1466	p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1) ! F ==> F
1467	p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1)
1468	END SELECT
1469	IF( srcv(jpr_itx1)%clgrid /= 'F' ) THEN
1470	CALL lbc_lnk( p_taui, 'F', -1. ) ; CALL lbc_lnk( p_tauj, 'F', -1. )
1471	ENDIF
1472	!
1473	CASE( 'C' ) ! C-grid ==> U,V
1474	SELECT CASE ( srcv(jpr_itx1)%clgrid )
1475	CASE( 'U' )
1476	p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1) ! (U,V) ==> (U,V)
1477	p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1)
1478	CASE( 'F' )
1479	DO jj = 2, jpjm1 ! F ==> (U,V)
1480	DO ji = fs_2, fs_jpim1 ! vector opt.
1481	p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji,jj,1) + frcv(jpr_itx1)%z3(ji ,jj-1,1) )
1482	p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(jj,jj,1) + frcv(jpr_ity1)%z3(ji-1,jj ,1) )
1483	END DO
1484	END DO
1485	CASE( 'T' )
1486	DO jj = 2, jpjm1 ! T ==> (U,V)
1487	DO ji = fs_2, fs_jpim1 ! vector opt.
1488	p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji+1,jj ,1) + frcv(jpr_itx1)%z3(ji,jj,1) )
1489	p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) )
1490	END DO
1491	END DO
1492	CASE( 'I' )
1493	DO jj = 2, jpjm1 ! I ==> (U,V)
1494	DO ji = 2, jpim1 ! NO vector opt.
1495	p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji+1,jj+1,1) + frcv(jpr_itx1)%z3(ji+1,jj ,1) )
1496	p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji+1,jj+1,1) + frcv(jpr_ity1)%z3(ji ,jj+1,1) )
1497	END DO
1498	END DO
1499	END SELECT
1500	IF( srcv(jpr_itx1)%clgrid /= 'U' ) THEN
1501	CALL lbc_lnk( p_taui, 'U', -1. ) ; CALL lbc_lnk( p_tauj, 'V', -1. )
1502	ENDIF
1503	END SELECT
1504
1505	ENDIF
1506	!
1507	CALL wrk_dealloc( jpi,jpj, ztx, zty )
1508	!
1509	IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_ice_tau')
1510	!
1511	END SUBROUTINE sbc_cpl_ice_tau
1512
1513
1514	SUBROUTINE sbc_cpl_ice_flx( p_frld, palbi, psst, pist )
1515	!!----------------------------------------------------------------------
1516	!! * ROUTINE sbc_cpl_ice_flx *
1517	!!
1518	!! ** Purpose : provide the heat and freshwater fluxes of the
1519	!! ocean-ice system.
1520	!!
1521	!! ** Method : transform the fields received from the atmosphere into
1522	!! surface heat and fresh water boundary condition for the
1523	!! ice-ocean system. The following fields are provided:
1524	!! * total non solar, solar and freshwater fluxes (qns_tot,
1525	!! qsr_tot and emp_tot) (total means weighted ice-ocean flux)
1526	!! NB: emp_tot include runoffs and calving.
1527	!! * fluxes over ice (qns_ice, qsr_ice, emp_ice) where
1528	!! emp_ice = sublimation - solid precipitation as liquid
1529	!! precipitation are re-routed directly to the ocean and
1530	!! runoffs and calving directly enter the ocean.
1531	!! * solid precipitation (sprecip), used to add to qns_tot
1532	!! the heat lost associated to melting solid precipitation
1533	!! over the ocean fraction.
1534	!! ===>> CAUTION here this changes the net heat flux received from
1535	!! the atmosphere
1536	!!
1537	!! - the fluxes have been separated from the stress as
1538	!! (a) they are updated at each ice time step compare to
1539	!! an update at each coupled time step for the stress, and
1540	!! (b) the conservative computation of the fluxes over the
1541	!! sea-ice area requires the knowledge of the ice fraction
1542	!! after the ice advection and before the ice thermodynamics,
1543	!! so that the stress is updated before the ice dynamics
1544	!! while the fluxes are updated after it.
1545	!!
1546	!! ** Action : update at each nf_ice time step:
1547	!! qns_tot, qsr_tot non-solar and solar total heat fluxes
1548	!! qns_ice, qsr_ice non-solar and solar heat fluxes over the ice
1549	!! emp_tot total evaporation - precipitation(liquid and solid) (-runoff)(-calving)
1550	!! emp_ice ice sublimation - solid precipitation over the ice
1551	!! dqns_ice d(non-solar heat flux)/d(Temperature) over the ice
1552	!! sprecip solid precipitation over the ocean
1553	!!----------------------------------------------------------------------
1554	REAL(wp), INTENT(in ), DIMENSION(:,:) :: p_frld ! lead fraction [0 to 1]
1555	! optional arguments, used only in 'mixed oce-ice' case
1556	REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo
1557	REAL(wp), INTENT(in ), DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius]
1558	REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin]
1559	!
1560	INTEGER :: jl ! dummy loop index
1561	REAL(wp), POINTER, DIMENSION(:,: ) :: zcptn, ztmp, zicefr, zmsk
1562	REAL(wp), POINTER, DIMENSION(:,: ) :: zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot
1563	REAL(wp), POINTER, DIMENSION(:,:,:) :: zqns_ice, zqsr_ice, zdqns_ice
1564	REAL(wp), POINTER, DIMENSION(:,: ) :: zevap, zsnw, zqns_oce, zqsr_oce, zqprec_ice, zqemp_oce ! for LIM3
1565	!!----------------------------------------------------------------------
1566	!
1567	IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_ice_flx')
1568	!
1569	CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot )
1570	CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice )
1571
1572	IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0)
1573	zicefr(:,:) = 1.- p_frld(:,:)
1574	zcptn(:,:) = rcp * sst_m(:,:)
1575	!
1576	! ! ========================= !
1577	! ! freshwater budget ! (emp)
1578	! ! ========================= !
1579	!
1580	! ! total Precipitation - total Evaporation (emp_tot)
1581	! ! solid precipitation - sublimation (emp_ice)
1582	! ! solid Precipitation (sprecip)
1583	! ! liquid + solid Precipitation (tprecip)
1584	SELECT CASE( TRIM( sn_rcv_emp%cldes ) )
1585	CASE( 'conservative' ) ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp
1586	zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1) ! May need to ensure positive here
1587	ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here
1588	zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:)
1589	zemp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1)
1590	CALL iom_put( 'rain' , frcv(jpr_rain)%z3(:,:,1) ) ! liquid precipitation
1591	IF( iom_use('hflx_rain_cea') ) &
1592	CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from liq. precip.
1593	IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) &
1594	ztmp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:)
1595	IF( iom_use('evap_ao_cea' ) ) &
1596	CALL iom_put( 'evap_ao_cea' , ztmp ) ! ice-free oce evap (cell average)
1597	IF( iom_use('hflx_evap_cea') ) &
1598	CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) ) ! heat flux from from evap (cell average)
1599	CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp
1600	zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1)
1601	zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1)
1602	zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1)
1603	ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:)
1604	END SELECT
1605
1606	IF( iom_use('subl_ai_cea') ) &
1607	CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) ! Sublimation over sea-ice (cell average)
1608	!
1609	! ! runoffs and calving (put in emp_tot)
1610	IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1)
1611	IF( srcv(jpr_cal)%laction ) THEN
1612	zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1)
1613	CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) )
1614	ENDIF
1615
1616	IF( ln_mixcpl ) THEN
1617	emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:)
1618	emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:)
1619	sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:)
1620	tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:)
1621	ELSE
1622	emp_tot(:,:) = zemp_tot(:,:)
1623	emp_ice(:,:) = zemp_ice(:,:)
1624	sprecip(:,:) = zsprecip(:,:)
1625	tprecip(:,:) = ztprecip(:,:)
1626	ENDIF
1627
1628	CALL iom_put( 'snowpre' , sprecip ) ! Snow
1629	IF( iom_use('snow_ao_cea') ) &
1630	CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:) ) ! Snow over ice-free ocean (cell average)
1631	IF( iom_use('snow_ai_cea') ) &
1632	CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) ) ! Snow over sea-ice (cell average)
1633
1634	! ! ========================= !
1635	SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) ! non solar heat fluxes ! (qns)
1636	! ! ========================= !
1637	CASE( 'oce only' ) ! the required field is directly provided
1638	zqns_tot(:,: ) = frcv(jpr_qnsoce)%z3(:,:,1)
1639	CASE( 'conservative' ) ! the required fields are directly provided
1640	zqns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1)
1641	IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN
1642	zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl)
1643	ELSE
1644	! Set all category values equal for the moment
1645	DO jl=1,jpl
1646	zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1)
1647	ENDDO
1648	ENDIF
1649	CASE( 'oce and ice' ) ! the total flux is computed from ocean and ice fluxes
1650	zqns_tot(:,: ) = p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1)
1651	IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN
1652	DO jl=1,jpl
1653	zqns_tot(:,: ) = zqns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl)
1654	zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl)
1655	ENDDO
1656	ELSE
1657	qns_tot(:,: ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1)
1658	DO jl=1,jpl
1659	zqns_tot(:,: ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1)
1660	zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1)
1661	ENDDO
1662	ENDIF
1663	CASE( 'mixed oce-ice' ) ! the ice flux is cumputed from the total flux, the SST and ice informations
1664	! NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED
1665	zqns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1)
1666	zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1) &
1667	& + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,: ) ) * p_frld(:,:) &
1668	& + pist(:,:,1) * zicefr(:,:) ) )
1669	END SELECT
1670	!!gm
1671	!! currently it is taken into account in leads budget but not in the zqns_tot, and thus not in
1672	!! the flux that enter the ocean....
1673	!! moreover 1 - it is not diagnose anywhere....
1674	!! 2 - it is unclear for me whether this heat lost is taken into account in the atmosphere or not...
1675	!!
1676	!! similar job should be done for snow and precipitation temperature
1677	!
1678	IF( srcv(jpr_cal)%laction ) THEN ! Iceberg melting
1679	ztmp(:,:) = frcv(jpr_cal)%z3(:,:,1) * lfus ! add the latent heat of iceberg melting
1680	zqns_tot(:,:) = zqns_tot(:,:) - ztmp(:,:)
1681	IF( iom_use('hflx_cal_cea') ) &
1682	CALL iom_put( 'hflx_cal_cea', ztmp + frcv(jpr_cal)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from calving
1683	ENDIF
1684
1685	ztmp(:,:) = p_frld(:,:) * zsprecip(:,:) * lfus
1686	IF( iom_use('hflx_snow_cea') ) CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) ) ! heat flux from snow (cell average)
1687
1688	#if defined key_lim3
1689	CALL wrk_alloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )
1690
1691	! --- evaporation --- !
1692	! clem: evap_ice is set to 0 for LIM3 since we still do not know what to do with sublimation
1693	! the problem is: the atm. imposes both mass evaporation and heat removed from the snow/ice
1694	! but it is incoherent WITH the ice model
1695	DO jl=1,jpl
1696	evap_ice(:,:,jl) = 0._wp ! should be: frcv(jpr_ievp)%z3(:,:,1)
1697	ENDDO
1698	zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean
1699
1700	! --- evaporation minus precipitation --- !
1701	emp_oce(:,:) = emp_tot(:,:) - emp_ice(:,:)
1702
1703	! --- non solar flux over ocean --- !
1704	! note: p_frld cannot be = 0 since we limit the ice concentration to amax
1705	zqns_oce = 0._wp
1706	WHERE( p_frld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:)
1707
1708	! --- heat flux associated with emp --- !
1709	zsnw(:,:) = 0._wp
1710	CALL lim_thd_snwblow( p_frld, zsnw ) ! snow distribution over ice after wind blowing
1711	zqemp_oce(:,:) = - zevap(:,:) * p_frld(:,:) * zcptn(:,:) & ! evap
1712	& + ( ztprecip(:,:) - zsprecip(:,:) ) * zcptn(:,:) & ! liquid precip
1713	& + zsprecip(:,:) * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean
1714	qemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) * zcptn(:,:) & ! ice evap
1715	& + zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice
1716
1717	! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- !
1718	zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus )
1719
1720	! --- total non solar flux --- !
1721	zqns_tot(:,:) = zqns_tot(:,:) + qemp_ice(:,:) + zqemp_oce(:,:)
1722
1723	! --- in case both coupled/forced are active, we must mix values --- !
1724	IF( ln_mixcpl ) THEN
1725	qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) + zqns_tot(:,:)* zmsk(:,:)
1726	qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:)
1727	DO jl=1,jpl
1728	qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) + zqns_ice(:,:,jl)* zmsk(:,:)
1729	ENDDO
1730	qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:)
1731	qemp_oce (:,:) = qemp_oce(:,:) * xcplmask(:,:,0) + zqemp_oce(:,:)* zmsk(:,:)
1732	!!clem evap_ice(:,:) = evap_ice(:,:) * xcplmask(:,:,0)
1733	ELSE
1734	qns_tot (:,: ) = zqns_tot (:,: )
1735	qns_oce (:,: ) = zqns_oce (:,: )
1736	qns_ice (:,:,:) = zqns_ice (:,:,:)
1737	qprec_ice(:,:) = zqprec_ice(:,:)
1738	qemp_oce (:,:) = zqemp_oce (:,:)
1739	ENDIF
1740
1741	CALL wrk_dealloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )
1742	#else
1743
1744	! clem: this formulation is certainly wrong... but better than it was...
1745	zqns_tot(:,:) = zqns_tot(:,:) & ! zqns_tot update over free ocean with:
1746	& - ztmp(:,:) & ! remove the latent heat flux of solid precip. melting
1747	& - ( zemp_tot(:,:) & ! remove the heat content of mass flux (assumed to be at SST)
1748	& - zemp_ice(:,:) * zicefr(:,:) ) * zcptn(:,:)
1749
1750	IF( ln_mixcpl ) THEN
1751	qns_tot(:,:) = qns(:,:) * p_frld(:,:) + SUM( qns_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk
1752	qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) + zqns_tot(:,:)* zmsk(:,:)
1753	DO jl=1,jpl
1754	qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) + zqns_ice(:,:,jl)* zmsk(:,:)
1755	ENDDO
1756	ELSE
1757	qns_tot(:,: ) = zqns_tot(:,: )
1758	qns_ice(:,:,:) = zqns_ice(:,:,:)
1759	ENDIF
1760
1761	#endif
1762
1763	! ! ========================= !
1764	SELECT CASE( TRIM( sn_rcv_qsr%cldes ) ) ! solar heat fluxes ! (qsr)
1765	! ! ========================= !
1766	CASE( 'oce only' )
1767	zqsr_tot(:,: ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) )
1768	CASE( 'conservative' )
1769	zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1)
1770	IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN
1771	zqsr_ice(:,:,1:jpl) = frcv(jpr_qsrice)%z3(:,:,1:jpl)
1772	ELSE
1773	! Set all category values equal for the moment
1774	DO jl=1,jpl
1775	zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1)
1776	ENDDO
1777	ENDIF
1778	zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1)
1779	zqsr_ice(:,:,1) = frcv(jpr_qsrice)%z3(:,:,1)
1780	CASE( 'oce and ice' )
1781	zqsr_tot(:,: ) = p_frld(:,:) * frcv(jpr_qsroce)%z3(:,:,1)
1782	IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN
1783	DO jl=1,jpl
1784	zqsr_tot(:,: ) = zqsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl)
1785	zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl)
1786	ENDDO
1787	ELSE
1788	qsr_tot(:,: ) = qsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1)
1789	DO jl=1,jpl
1790	zqsr_tot(:,: ) = zqsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1)
1791	zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1)
1792	ENDDO
1793	ENDIF
1794	CASE( 'mixed oce-ice' )
1795	zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1)
1796	! NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED
1797	! Create solar heat flux over ice using incoming solar heat flux and albedos
1798	! ( see OASIS3 user guide, 5th edition, p39 )
1799	zqsr_ice(:,:,1) = frcv(jpr_qsrmix)%z3(:,:,1) * ( 1.- palbi(:,:,1) ) &
1800	& / ( 1.- ( albedo_oce_mix(:,: ) * p_frld(:,:) &
1801	& + palbi (:,:,1) * zicefr(:,:) ) )
1802	END SELECT
1803	IF( ln_dm2dc .AND. ln_cpl ) THEN ! modify qsr to include the diurnal cycle
1804	zqsr_tot(:,: ) = sbc_dcy( zqsr_tot(:,: ) )
1805	DO jl=1,jpl
1806	zqsr_ice(:,:,jl) = sbc_dcy( zqsr_ice(:,:,jl) )
1807	ENDDO
1808	ENDIF
1809
1810	#if defined key_lim3
1811	CALL wrk_alloc( jpi,jpj, zqsr_oce )
1812	! --- solar flux over ocean --- !
1813	! note: p_frld cannot be = 0 since we limit the ice concentration to amax
1814	zqsr_oce = 0._wp
1815	WHERE( p_frld /= 0._wp ) zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i * zqsr_ice, dim=3 ) ) / p_frld(:,:)
1816
1817	IF( ln_mixcpl ) THEN ; qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) + zqsr_oce(:,:)* zmsk(:,:)
1818	ELSE ; qsr_oce(:,:) = zqsr_oce(:,:) ; ENDIF
1819
1820	CALL wrk_dealloc( jpi,jpj, zqsr_oce )
1821	#endif
1822
1823	IF( ln_mixcpl ) THEN
1824	qsr_tot(:,:) = qsr(:,:) * p_frld(:,:) + SUM( qsr_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk
1825	qsr_tot(:,:) = qsr_tot(:,:) * xcplmask(:,:,0) + zqsr_tot(:,:)* zmsk(:,:)
1826	DO jl=1,jpl
1827	qsr_ice(:,:,jl) = qsr_ice(:,:,jl) * xcplmask(:,:,0) + zqsr_ice(:,:,jl)* zmsk(:,:)
1828	ENDDO
1829	ELSE
1830	qsr_tot(:,: ) = zqsr_tot(:,: )
1831	qsr_ice(:,:,:) = zqsr_ice(:,:,:)
1832	ENDIF
1833
1834	! ! ========================= !
1835	SELECT CASE( TRIM( sn_rcv_dqnsdt%cldes ) ) ! d(qns)/dt !
1836	! ! ========================= !
1837	CASE ('coupled')
1838	IF ( TRIM(sn_rcv_dqnsdt%clcat) == 'yes' ) THEN
1839	zdqns_ice(:,:,1:jpl) = frcv(jpr_dqnsdt)%z3(:,:,1:jpl)
1840	ELSE
1841	! Set all category values equal for the moment
1842	DO jl=1,jpl
1843	zdqns_ice(:,:,jl) = frcv(jpr_dqnsdt)%z3(:,:,1)
1844	ENDDO
1845	ENDIF
1846	END SELECT
1847
1848	IF( ln_mixcpl ) THEN
1849	DO jl=1,jpl
1850	dqns_ice(:,:,jl) = dqns_ice(:,:,jl) * xcplmask(:,:,0) + zdqns_ice(:,:,jl) * zmsk(:,:)
1851	ENDDO
1852	ELSE
1853	dqns_ice(:,:,:) = zdqns_ice(:,:,:)
1854	ENDIF
1855
1856	! ! ========================= !
1857	SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) ) ! topmelt and botmelt !
1858	! ! ========================= !
1859	CASE ('coupled')
1860	topmelt(:,:,:)=frcv(jpr_topm)%z3(:,:,:)
1861	botmelt(:,:,:)=frcv(jpr_botm)%z3(:,:,:)
1862	END SELECT
1863
1864	! Surface transimission parameter io (Maykut Untersteiner , 1971 ; Ebert and Curry, 1993 )
1865	! Used for LIM2 and LIM3
1866	! Coupled case: since cloud cover is not received from atmosphere
1867	! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81)
1868	fr1_i0(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice )
1869	fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice )
1870
1871	CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot )
1872	CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice )
1873	!
1874	IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_ice_flx')
1875	!
1876	END SUBROUTINE sbc_cpl_ice_flx
1877
1878
1879	SUBROUTINE sbc_cpl_snd( kt )
1880	!!----------------------------------------------------------------------
1881	!! * ROUTINE sbc_cpl_snd *
1882	!!
1883	!! ** Purpose : provide the ocean-ice informations to the atmosphere
1884	!!
1885	!! ** Method : send to the atmosphere through a call to cpl_snd
1886	!! all the needed fields (as defined in sbc_cpl_init)
1887	!!----------------------------------------------------------------------
1888	INTEGER, INTENT(in) :: kt
1889	!
1890	INTEGER :: ji, jj, jl ! dummy loop indices
1891	INTEGER :: ikchoix
1892	INTEGER :: isec, info ! local integer
1893	REAL(wp) :: zumax, zvmax
1894	REAL(wp), POINTER, DIMENSION(:,:) :: zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1
1895	REAL(wp), POINTER, DIMENSION(:,:,:) :: ztmp3, ztmp4
1896
1897	#if defined key_medusa
1898	! RSRH Temporarily definitition of array used in medusa coupling until we actually have the medusa code included in the build
1899	REAL(wp) :: TRC2D_TEST(jpi,jpj)
1900	#endif
1901
1902	!!----------------------------------------------------------------------
1903	!
1904	IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_snd')
1905	!
1906	CALL wrk_alloc( jpi,jpj, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 )
1907	CALL wrk_alloc( jpi,jpj,jpl, ztmp3, ztmp4 )
1908
1909	isec = ( kt - nit000 ) * NINT(rdttra(1)) ! date of exchanges
1910
1911	zfr_l(:,:) = 1.- fr_i(:,:)
1912	! ! ------------------------- !
1913	! ! Surface temperature ! in Kelvin
1914	! ! ------------------------- !
1915	IF( ssnd(jps_toce)%laction .OR. ssnd(jps_tice)%laction .OR. ssnd(jps_tmix)%laction ) THEN
1916
1917	IF ( nn_components == jp_iam_opa ) THEN
1918	ztmp1(:,:) = tsn(:,:,1,jp_tem) ! send temperature as it is (potential or conservative) -> use of ln_useCT on the received part
1919	ELSE
1920	! we must send the surface potential temperature
1921	IF( ln_useCT ) THEN ; ztmp1(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) )
1922	ELSE ; ztmp1(:,:) = tsn(:,:,1,jp_tem)
1923	ENDIF
1924	!
1925	SELECT CASE( sn_snd_temp%cldes)
1926	CASE( 'oce only' ) ; ztmp1(:,:) = ztmp1(:,:) + rt0
1927	CASE( 'oce and ice' ) ; ztmp1(:,:) = ztmp1(:,:) + rt0
1928	SELECT CASE( sn_snd_temp%clcat )
1929	CASE( 'yes' )
1930	ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl)
1931	CASE( 'no' )
1932	WHERE( SUM( a_i, dim=3 ) /= 0. )
1933	ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 )
1934	ELSEWHERE
1935	ztmp3(:,:,1) = rt0 ! TODO: Is freezing point a good default? (Maybe SST is better?)
1936	END WHERE
1937	CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' )
1938	END SELECT
1939	CASE( 'weighted oce and ice' ) ; ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:)
1940	SELECT CASE( sn_snd_temp%clcat )
1941	CASE( 'yes' )
1942	ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl)
1943	CASE( 'no' )
1944	ztmp3(:,:,:) = 0.0
1945	DO jl=1,jpl
1946	ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl)
1947	ENDDO
1948	CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' )
1949	END SELECT
1950	CASE( 'mixed oce-ice' )
1951	ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:)
1952	DO jl=1,jpl
1953	ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl)
1954	ENDDO
1955	CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' )
1956	END SELECT
1957	ENDIF
1958	IF( ssnd(jps_toce)%laction ) CALL cpl_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
1959	IF( ssnd(jps_tice)%laction ) CALL cpl_snd( jps_tice, isec, ztmp3, info )
1960	IF( ssnd(jps_tmix)%laction ) CALL cpl_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
1961	ENDIF
1962	! ! ------------------------- !
1963	! ! Albedo !
1964	! ! ------------------------- !
1965	IF( ssnd(jps_albice)%laction ) THEN ! ice
1966	SELECT CASE( sn_snd_alb%cldes )
1967	CASE( 'ice' ) ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl)
1968	CASE( 'weighted ice' ) ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl)
1969	CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' )
1970	END SELECT
1971	CALL cpl_snd( jps_albice, isec, ztmp3, info )
1972	ENDIF
1973	IF( ssnd(jps_albmix)%laction ) THEN ! mixed ice-ocean
1974	ztmp1(:,:) = albedo_oce_mix(:,:) * zfr_l(:,:)
1975	DO jl=1,jpl
1976	ztmp1(:,:) = ztmp1(:,:) + alb_ice(:,:,jl) * a_i(:,:,jl)
1977	ENDDO
1978	CALL cpl_snd( jps_albmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
1979	ENDIF
1980	! ! ------------------------- !
1981	! ! Ice fraction & Thickness !
1982	! ! ------------------------- !
1983	! Send ice fraction field to atmosphere
1984	IF( ssnd(jps_fice)%laction ) THEN
1985	SELECT CASE( sn_snd_thick%clcat )
1986	CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(:,:,1:jpl)
1987	CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(:,: )
1988	CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' )
1989	END SELECT
1990	IF( ssnd(jps_fice)%laction ) CALL cpl_snd( jps_fice, isec, ztmp3, info )
1991	ENDIF
1992
1993	! Send ice fraction field to OPA (sent by SAS in SAS-OPA coupling)
1994	IF( ssnd(jps_fice2)%laction ) THEN
1995	ztmp3(:,:,1) = fr_i(:,:)
1996	IF( ssnd(jps_fice2)%laction ) CALL cpl_snd( jps_fice2, isec, ztmp3, info )
1997	ENDIF
1998
1999	! Send ice and snow thickness field
2000	IF( ssnd(jps_hice)%laction .OR. ssnd(jps_hsnw)%laction ) THEN
2001	SELECT CASE( sn_snd_thick%cldes)
2002	CASE( 'none' ) ! nothing to do
2003	CASE( 'weighted ice and snow' )
2004	SELECT CASE( sn_snd_thick%clcat )
2005	CASE( 'yes' )
2006	ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl) * a_i(:,:,1:jpl)
2007	ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl) * a_i(:,:,1:jpl)
2008	CASE( 'no' )
2009	ztmp3(:,:,:) = 0.0 ; ztmp4(:,:,:) = 0.0
2010	DO jl=1,jpl
2011	ztmp3(:,:,1) = ztmp3(:,:,1) + ht_i(:,:,jl) * a_i(:,:,jl)
2012	ztmp4(:,:,1) = ztmp4(:,:,1) + ht_s(:,:,jl) * a_i(:,:,jl)
2013	ENDDO
2014	CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' )
2015	END SELECT
2016	CASE( 'ice and snow' )
2017	SELECT CASE( sn_snd_thick%clcat )
2018	CASE( 'yes' )
2019	ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl)
2020	ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl)
2021	CASE( 'no' )
2022	WHERE( SUM( a_i, dim=3 ) /= 0. )
2023	ztmp3(:,:,1) = SUM( ht_i * a_i, dim=3 ) / SUM( a_i, dim=3 )
2024	ztmp4(:,:,1) = SUM( ht_s * a_i, dim=3 ) / SUM( a_i, dim=3 )
2025	ELSEWHERE
2026	ztmp3(:,:,1) = 0.
2027	ztmp4(:,:,1) = 0.
2028	END WHERE
2029	CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' )
2030	END SELECT
2031	CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%cldes' )
2032	END SELECT
2033	IF( ssnd(jps_hice)%laction ) CALL cpl_snd( jps_hice, isec, ztmp3, info )
2034	IF( ssnd(jps_hsnw)%laction ) CALL cpl_snd( jps_hsnw, isec, ztmp4, info )
2035	ENDIF
2036	!
2037	#if defined key_cpl_carbon_cycle
2038	! ! ------------------------- !
2039	! ! CO2 flux from PISCES !
2040	! ! ------------------------- !
2041	IF( ssnd(jps_co2)%laction ) CALL cpl_snd( jps_co2, isec, RESHAPE ( oce_co2, (/jpi,jpj,1/) ) , info )
2042	!
2043	#endif
2044
2045
2046	!! JPALM : 03-feb-2015 coupling MEDUSA-UKCA
2047	!! add soing exactely the same that CO2 fluxes
2048	!! of PISCES
2049	!! add CO2-MEDUSA
2050	!! add DMS-MEDUSA
2051	!! May add also a coupling MED-UKCA key
2052
2053
2054	#if defined key_medusa
2055	! RSRH. We don't want to use magic numbers in the code (i.e. 98 and 221).
2056	! These need moving to a parameter statement (as part of MEDUSA code) or even specifying in a namelist
2057	! so the following code MUST NOT be viewed as anything more than temporary.
2058	! IF( ssnd(jps_bio_co2)%laction ) CALL cpl_prism_snd( jps_bio_co2, isec, trc2d(:,:,98:98), info )
2059	TRC2D_TEST(:,:) = 0.0
2060	IF( ssnd(jps_bio_co2)%laction ) CALL cpl_prism_snd( jps_bio_co2, isec, trc2d_TEST(:,:), info )
2061
2062	IF( ssnd(jps_bio_dms)%laction ) THEN
2063	! We need to multiply DMS by a conversion factor to get values in the standard units expected in
2064	! the coupling space.
2065	! ztmp1(:,: ) = trc2d(:,:,221) * dms_unit_conv
2066	ztmp1(:,: ) = trc2d_TEST(:,:) * dms_unit_conv
2067	CALL cpl_prism_snd( jps_bio_dms, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
2068	ENDIF
2069	#endif
2070	! ! ------------------------- !
2071	IF( ssnd(jps_ocx1)%laction ) THEN ! Surface current !
2072	! ! ------------------------- !
2073	!
2074	! j+1 j -----V---F
2075	! surface velocity always sent from T point ! \|
2076	! [except for HadGEM3] j \| T U
2077	! \| \|
2078	! j j-1 -I-------\|
2079	! (for I) \| \|
2080	! i-1 i i
2081	! i i+1 (for I)
2082	IF( nn_components == jp_iam_opa ) THEN
2083	zotx1(:,:) = un(:,:,1)
2084	zoty1(:,:) = vn(:,:,1)
2085	ELSE
2086	SELECT CASE( TRIM( sn_snd_crt%cldes ) )
2087	CASE( 'oce only' ) ! C-grid ==> T
2088	IF ( TRIM( sn_snd_crt%clvgrd ) == 'T' ) THEN
2089	DO jj = 2, jpjm1
2090	DO ji = fs_2, fs_jpim1 ! vector opt.
2091	zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) )
2092	zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) )
2093	END DO
2094	END DO
2095	ELSE
2096	! Temporarily Changed for UKV
2097	DO jj = 2, jpjm1
2098	DO ji = 2, jpim1
2099	zotx1(ji,jj) = un(ji,jj,1)
2100	zoty1(ji,jj) = vn(ji,jj,1)
2101	END DO
2102	END DO
2103	ENDIF
2104	CASE( 'weighted oce and ice' )
2105	SELECT CASE ( cp_ice_msh )
2106	CASE( 'C' ) ! Ocean and Ice on C-grid ==> T
2107	DO jj = 2, jpjm1
2108	DO ji = fs_2, fs_jpim1 ! vector opt.
2109	zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj)
2110	zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * zfr_l(ji,jj)
2111	zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj)
2112	zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj)
2113	END DO
2114	END DO
2115	CASE( 'I' ) ! Ocean on C grid, Ice on I-point (B-grid) ==> T
2116	DO jj = 2, jpjm1
2117	DO ji = 2, jpim1 ! NO vector opt.
2118	zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj)
2119	zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj)
2120	zitx1(ji,jj) = 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1) &
2121	& + u_ice(ji+1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj)
2122	zity1(ji,jj) = 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1) &
2123	& + v_ice(ji+1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj)
2124	END DO
2125	END DO
2126	CASE( 'F' ) ! Ocean on C grid, Ice on F-point (B-grid) ==> T
2127	DO jj = 2, jpjm1
2128	DO ji = 2, jpim1 ! NO vector opt.
2129	zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj)
2130	zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj)
2131	zitx1(ji,jj) = 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1) &
2132	& + u_ice(ji-1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj)
2133	zity1(ji,jj) = 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1) &
2134	& + v_ice(ji-1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj)
2135	END DO
2136	END DO
2137	END SELECT
2138	CALL lbc_lnk( zitx1, 'T', -1. ) ; CALL lbc_lnk( zity1, 'T', -1. )
2139	CASE( 'mixed oce-ice' )
2140	SELECT CASE ( cp_ice_msh )
2141	CASE( 'C' ) ! Ocean and Ice on C-grid ==> T
2142	DO jj = 2, jpjm1
2143	DO ji = fs_2, fs_jpim1 ! vector opt.
2144	zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) &
2145	& + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj)
2146	zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * zfr_l(ji,jj) &
2147	& + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj)
2148	END DO
2149	END DO
2150	CASE( 'I' ) ! Ocean on C grid, Ice on I-point (B-grid) ==> T
2151	DO jj = 2, jpjm1
2152	DO ji = 2, jpim1 ! NO vector opt.
2153	zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj) &
2154	& + 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1) &
2155	& + u_ice(ji+1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj)
2156	zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj) &
2157	& + 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1) &
2158	& + v_ice(ji+1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj)
2159	END DO
2160	END DO
2161	CASE( 'F' ) ! Ocean on C grid, Ice on F-point (B-grid) ==> T
2162	IF ( TRIM( sn_snd_crt%clvgrd ) == 'T' ) THEN
2163	DO jj = 2, jpjm1
2164	DO ji = 2, jpim1 ! NO vector opt.
2165	zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj,1) ) * zfr_l(ji,jj) &
2166	& + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1) &
2167	& + u_ice(ji-1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj)
2168	zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji,jj-1,1) ) * zfr_l(ji,jj) &
2169	& + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1) &
2170	& + v_ice(ji-1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj)
2171	END DO
2172	END DO
2173	#if defined key_cice
2174	ELSE
2175	! Temporarily Changed for HadGEM3
2176	DO jj = 2, jpjm1
2177	DO ji = 2, jpim1 ! NO vector opt.
2178	zotx1(ji,jj) = (1.0-fr_iu(ji,jj)) * un(ji,jj,1) &
2179	& + fr_iu(ji,jj) * 0.5 * ( u_ice(ji,jj-1) + u_ice(ji,jj) )
2180	zoty1(ji,jj) = (1.0-fr_iv(ji,jj)) * vn(ji,jj,1) &
2181	& + fr_iv(ji,jj) * 0.5 * ( v_ice(ji-1,jj) + v_ice(ji,jj) )
2182	END DO
2183	END DO
2184	#endif
2185	ENDIF
2186	END SELECT
2187	END SELECT
2188	CALL lbc_lnk( zotx1, ssnd(jps_ocx1)%clgrid, -1. ) ; CALL lbc_lnk( zoty1, ssnd(jps_ocy1)%clgrid, -1. )
2189	!
2190	ENDIF
2191	!
2192	!
2193	IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components
2194	! ! Ocean component
2195	IF ( TRIM( sn_snd_crt%clvgrd ) == 'T' ) THEN
2196	CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component
2197	CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component
2198	zotx1(:,:) = ztmp1(:,:) ! overwrite the components
2199	zoty1(:,:) = ztmp2(:,:)
2200	IF( ssnd(jps_ivx1)%laction ) THEN ! Ice component
2201	CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component
2202	CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component
2203	zitx1(:,:) = ztmp1(:,:) ! overwrite the components
2204	zity1(:,:) = ztmp2(:,:)
2205	ENDIF
2206	ELSE
2207	! Temporary code for HadGEM3 - will be removed eventually.
2208	! Only applies when we want uvel on U grid and vvel on V grid
2209	! Rotate U and V onto geographic grid before sending.
2210
2211	DO jj=2,jpjm1
2212	DO ji=2,jpim1
2213	ztmp1(ji,jj)=0.25*vmask(ji,jj,1) &
2214	*(zotx1(ji,jj)+zotx1(ji-1,jj) &
2215	+zotx1(ji,jj+1)+zotx1(ji-1,jj+1))
2216	ztmp2(ji,jj)=0.25*umask(ji,jj,1) &
2217	*(zoty1(ji,jj)+zoty1(ji+1,jj) &
2218	+zoty1(ji,jj-1)+zoty1(ji+1,jj-1))
2219	ENDDO
2220	ENDDO
2221
2222	! Ensure any N fold and wrap columns are updated
2223	CALL lbc_lnk(ztmp1, 'V', -1.0)
2224	CALL lbc_lnk(ztmp2, 'U', -1.0)
2225
2226	ikchoix = -1
2227	CALL repcmo (zotx1,ztmp2,ztmp1,zoty1,zotx1,zoty1,ikchoix)
2228	ENDIF
2229	ENDIF
2230	!
2231	! spherical coordinates to cartesian -> 2 components to 3 components
2232	IF( TRIM( sn_snd_crt%clvref ) == 'cartesian' ) THEN
2233	ztmp1(:,:) = zotx1(:,:) ! ocean currents
2234	ztmp2(:,:) = zoty1(:,:)
2235	CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 )
2236	!
2237	IF( ssnd(jps_ivx1)%laction ) THEN ! ice velocities
2238	ztmp1(:,:) = zitx1(:,:)
2239	ztmp1(:,:) = zity1(:,:)
2240	CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 )
2241	ENDIF
2242	ENDIF
2243	!
2244	IF( ssnd(jps_ocx1)%laction ) CALL cpl_snd( jps_ocx1, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid
2245	IF( ssnd(jps_ocy1)%laction ) CALL cpl_snd( jps_ocy1, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid
2246	IF( ssnd(jps_ocz1)%laction ) CALL cpl_snd( jps_ocz1, isec, RESHAPE ( zotz1, (/jpi,jpj,1/) ), info ) ! ocean z current 1st grid
2247	!
2248	IF( ssnd(jps_ivx1)%laction ) CALL cpl_snd( jps_ivx1, isec, RESHAPE ( zitx1, (/jpi,jpj,1/) ), info ) ! ice x current 1st grid
2249	IF( ssnd(jps_ivy1)%laction ) CALL cpl_snd( jps_ivy1, isec, RESHAPE ( zity1, (/jpi,jpj,1/) ), info ) ! ice y current 1st grid
2250	IF( ssnd(jps_ivz1)%laction ) CALL cpl_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/jpi,jpj,1/) ), info ) ! ice z current 1st grid
2251	!
2252	ENDIF
2253	!
2254	!
2255	! Fields sent by OPA to SAS when doing OPA<->SAS coupling
2256	! ! SSH
2257	IF( ssnd(jps_ssh )%laction ) THEN
2258	! ! removed inverse barometer ssh when Patm
2259	! forcing is used (for sea-ice dynamics)
2260	IF( ln_apr_dyn ) THEN ; ztmp1(:,:) = sshb(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) )
2261	ELSE ; ztmp1(:,:) = sshn(:,:)
2262	ENDIF
2263	CALL cpl_snd( jps_ssh , isec, RESHAPE ( ztmp1 , (/jpi,jpj,1/) ), info )
2264
2265	ENDIF
2266	! ! SSS
2267	IF( ssnd(jps_soce )%laction ) THEN
2268	CALL cpl_snd( jps_soce , isec, RESHAPE ( tsn(:,:,1,jp_sal), (/jpi,jpj,1/) ), info )
2269	ENDIF
2270	! ! first T level thickness
2271	IF( ssnd(jps_e3t1st )%laction ) THEN
2272	CALL cpl_snd( jps_e3t1st, isec, RESHAPE ( fse3t_n(:,:,1) , (/jpi,jpj,1/) ), info )
2273	ENDIF
2274	! ! Qsr fraction
2275	IF( ssnd(jps_fraqsr)%laction ) THEN
2276	CALL cpl_snd( jps_fraqsr, isec, RESHAPE ( fraqsr_1lev(:,:) , (/jpi,jpj,1/) ), info )
2277	ENDIF
2278	!
2279	! Fields sent by SAS to OPA when OASIS coupling
2280	! ! Solar heat flux
2281	IF( ssnd(jps_qsroce)%laction ) CALL cpl_snd( jps_qsroce, isec, RESHAPE ( qsr , (/jpi,jpj,1/) ), info )
2282	IF( ssnd(jps_qnsoce)%laction ) CALL cpl_snd( jps_qnsoce, isec, RESHAPE ( qns , (/jpi,jpj,1/) ), info )
2283	IF( ssnd(jps_oemp )%laction ) CALL cpl_snd( jps_oemp , isec, RESHAPE ( emp , (/jpi,jpj,1/) ), info )
2284	IF( ssnd(jps_sflx )%laction ) CALL cpl_snd( jps_sflx , isec, RESHAPE ( sfx , (/jpi,jpj,1/) ), info )
2285	IF( ssnd(jps_otx1 )%laction ) CALL cpl_snd( jps_otx1 , isec, RESHAPE ( utau, (/jpi,jpj,1/) ), info )
2286	IF( ssnd(jps_oty1 )%laction ) CALL cpl_snd( jps_oty1 , isec, RESHAPE ( vtau, (/jpi,jpj,1/) ), info )
2287	IF( ssnd(jps_rnf )%laction ) CALL cpl_snd( jps_rnf , isec, RESHAPE ( rnf , (/jpi,jpj,1/) ), info )
2288	IF( ssnd(jps_taum )%laction ) CALL cpl_snd( jps_taum , isec, RESHAPE ( taum, (/jpi,jpj,1/) ), info )
2289
2290	CALL wrk_dealloc( jpi,jpj, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 )
2291	CALL wrk_dealloc( jpi,jpj,jpl, ztmp3, ztmp4 )
2292	!
2293	IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_snd')
2294	!
2295	END SUBROUTINE sbc_cpl_snd
2296
2297	!!======================================================================
2298	END MODULE sbccpl

Note: See TracBrowser for help on using the repository browser.

Download in other formats: