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_r5107_hadgem3_cplseq/NEMOGCM/NEMO/OPA_SRC/SBC – NEMO

Context Navigation

source: branches/UKMO/dev_r5107_hadgem3_cplseq/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90 @ 5491

Last change on this file since 5491 was 5491, checked in by dancopsey, 9 years ago
Hardwire only two models as nn_cplmodel has not been read in from the namelist yet.
File size: 94.3 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 sbcdcy ! surface boundary condition: diurnal cycle
24	USE phycst ! physical constants
25	#if defined key_lim3
26	USE par_ice ! ice parameters
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
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	#if defined key_cpl_carbon_cycle
44	USE p4zflx, ONLY : oce_co2
45	#endif
46	#if defined key_cice
47	USE ice_domain_size, only: ncat
48	#endif
49	IMPLICIT NONE
50	PRIVATE
51	!EM XIOS-OASIS-MCT compliance
52	PUBLIC sbc_cpl_init ! routine called by sbcmod.F90
53	PUBLIC sbc_cpl_rcv ! routine called by sbc_ice_lim(_2).F90
54	PUBLIC sbc_cpl_snd ! routine called by step.F90
55	PUBLIC sbc_cpl_ice_tau ! routine called by sbc_ice_lim(_2).F90
56	PUBLIC sbc_cpl_ice_flx ! routine called by sbc_ice_lim(_2).F90
57	PUBLIC sbc_cpl_alloc ! routine called in sbcice_cice.F90
58
59	INTEGER, PARAMETER :: jpr_otx1 = 1 ! 3 atmosphere-ocean stress components on grid 1
60	INTEGER, PARAMETER :: jpr_oty1 = 2 !
61	INTEGER, PARAMETER :: jpr_otz1 = 3 !
62	INTEGER, PARAMETER :: jpr_otx2 = 4 ! 3 atmosphere-ocean stress components on grid 2
63	INTEGER, PARAMETER :: jpr_oty2 = 5 !
64	INTEGER, PARAMETER :: jpr_otz2 = 6 !
65	INTEGER, PARAMETER :: jpr_itx1 = 7 ! 3 atmosphere-ice stress components on grid 1
66	INTEGER, PARAMETER :: jpr_ity1 = 8 !
67	INTEGER, PARAMETER :: jpr_itz1 = 9 !
68	INTEGER, PARAMETER :: jpr_itx2 = 10 ! 3 atmosphere-ice stress components on grid 2
69	INTEGER, PARAMETER :: jpr_ity2 = 11 !
70	INTEGER, PARAMETER :: jpr_itz2 = 12 !
71	INTEGER, PARAMETER :: jpr_qsroce = 13 ! Qsr above the ocean
72	INTEGER, PARAMETER :: jpr_qsrice = 14 ! Qsr above the ice
73	INTEGER, PARAMETER :: jpr_qsrmix = 15
74	INTEGER, PARAMETER :: jpr_qnsoce = 16 ! Qns above the ocean
75	INTEGER, PARAMETER :: jpr_qnsice = 17 ! Qns above the ice
76	INTEGER, PARAMETER :: jpr_qnsmix = 18
77	INTEGER, PARAMETER :: jpr_rain = 19 ! total liquid precipitation (rain)
78	INTEGER, PARAMETER :: jpr_snow = 20 ! solid precipitation over the ocean (snow)
79	INTEGER, PARAMETER :: jpr_tevp = 21 ! total evaporation
80	INTEGER, PARAMETER :: jpr_ievp = 22 ! solid evaporation (sublimation)
81	INTEGER, PARAMETER :: jpr_sbpr = 23 ! sublimation - liquid precipitation - solid precipitation
82	INTEGER, PARAMETER :: jpr_semp = 24 ! solid freshwater budget (sublimation - snow)
83	INTEGER, PARAMETER :: jpr_oemp = 25 ! ocean freshwater budget (evap - precip)
84	INTEGER, PARAMETER :: jpr_w10m = 26 ! 10m wind
85	INTEGER, PARAMETER :: jpr_dqnsdt = 27 ! d(Q non solar)/d(temperature)
86	INTEGER, PARAMETER :: jpr_rnf = 28 ! runoffs
87	INTEGER, PARAMETER :: jpr_cal = 29 ! calving
88	INTEGER, PARAMETER :: jpr_taum = 30 ! wind stress module
89	INTEGER, PARAMETER :: jpr_co2 = 31
90	INTEGER, PARAMETER :: jpr_topm = 32 ! topmeltn
91	INTEGER, PARAMETER :: jpr_botm = 33 ! botmeltn
92	INTEGER, PARAMETER :: jprcv = 33 ! total number of fields received
93
94	INTEGER, PARAMETER :: jps_fice = 1 ! ice fraction
95	INTEGER, PARAMETER :: jps_toce = 2 ! ocean temperature
96	INTEGER, PARAMETER :: jps_tice = 3 ! ice temperature
97	INTEGER, PARAMETER :: jps_tmix = 4 ! mixed temperature (ocean+ice)
98	INTEGER, PARAMETER :: jps_albice = 5 ! ice albedo
99	INTEGER, PARAMETER :: jps_albmix = 6 ! mixed albedo
100	INTEGER, PARAMETER :: jps_hice = 7 ! ice thickness
101	INTEGER, PARAMETER :: jps_hsnw = 8 ! snow thickness
102	INTEGER, PARAMETER :: jps_ocx1 = 9 ! ocean current on grid 1
103	INTEGER, PARAMETER :: jps_ocy1 = 10 !
104	INTEGER, PARAMETER :: jps_ocz1 = 11 !
105	INTEGER, PARAMETER :: jps_ivx1 = 12 ! ice current on grid 1
106	INTEGER, PARAMETER :: jps_ivy1 = 13 !
107	INTEGER, PARAMETER :: jps_ivz1 = 14 !
108	INTEGER, PARAMETER :: jps_co2 = 15
109	INTEGER, PARAMETER :: jpsnd = 15 ! total number of fields sended
110
111	! !! namelist namsbc_cpl
112	TYPE :: FLD_C
113	CHARACTER(len = 32) :: cldes ! desciption of the coupling strategy
114	CHARACTER(len = 32) :: clcat ! multiple ice categories strategy
115	CHARACTER(len = 32) :: clvref ! reference of vector ('spherical' or 'cartesian')
116	CHARACTER(len = 32) :: clvor ! orientation of vector fields ('eastward-northward' or 'local grid')
117	CHARACTER(len = 32) :: clvgrd ! grids on which is located the vector fields
118	END TYPE FLD_C
119	! Send to the atmosphere !
120	TYPE(FLD_C) :: sn_snd_temp, sn_snd_alb, sn_snd_thick, sn_snd_crt, sn_snd_co2
121	! Received from the atmosphere !
122	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
123	TYPE(FLD_C) :: sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2
124	! Other namelist parameters !
125	INTEGER :: nn_cplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data
126	LOGICAL :: ln_usecplmask ! use a coupling mask file to merge data received from several models
127	! -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel)
128
129	REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: xcplmask
130
131	TYPE :: DYNARR
132	REAL(wp), POINTER, DIMENSION(:,:,:) :: z3
133	END TYPE DYNARR
134
135	TYPE( DYNARR ), SAVE, DIMENSION(jprcv) :: frcv ! all fields recieved from the atmosphere
136
137	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: albedo_oce_mix ! ocean albedo sent to atmosphere (mix clear/overcast sky)
138
139	INTEGER , ALLOCATABLE, SAVE, DIMENSION( :) :: nrcvinfo ! OASIS info argument
140
141	!! Substitution
142	# include "vectopt_loop_substitute.h90"
143	!!----------------------------------------------------------------------
144	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
145	!! $Id$
146	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
147	!!----------------------------------------------------------------------
148
149	CONTAINS
150
151	INTEGER FUNCTION sbc_cpl_alloc()
152	!!----------------------------------------------------------------------
153	!! * FUNCTION sbc_cpl_alloc *
154	!!----------------------------------------------------------------------
155	INTEGER :: ierr(3)
156	!!----------------------------------------------------------------------
157	ierr(:) = 0
158	!
159	ALLOCATE( albedo_oce_mix(jpi,jpj), nrcvinfo(jprcv), STAT=ierr(1) )
160
161	#if ! defined key_lim3 && ! defined key_lim2 && ! defined key_cice
162	ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) ) ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init)
163	#endif
164	!ALLOCATE( xcplmask(jpi,jpj,nn_cplmodel) , STAT=ierr(3) )
165	! Hardwire only two models as nn_cplmodel has not been read in
166	! from the namelist yet.
167	ALLOCATE( xcplmask(jpi,jpj,2) , STAT=ierr(3) )
168	!
169	sbc_cpl_alloc = MAXVAL( ierr )
170	IF( lk_mpp ) CALL mpp_sum ( sbc_cpl_alloc )
171	IF( sbc_cpl_alloc > 0 ) CALL ctl_warn('sbc_cpl_alloc: allocation of arrays failed')
172	!
173	END FUNCTION sbc_cpl_alloc
174
175
176	SUBROUTINE sbc_cpl_init( k_ice )
177	!!----------------------------------------------------------------------
178	!! * ROUTINE sbc_cpl_init *
179	!!
180	!! ** Purpose : Initialisation of send and received information from
181	!! the atmospheric component
182	!!
183	!! ** Method : * Read namsbc_cpl namelist
184	!! * define the receive interface
185	!! * define the send interface
186	!! * initialise the OASIS coupler
187	!!----------------------------------------------------------------------
188	INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3)
189	!!
190	INTEGER :: jn ! dummy loop index
191	INTEGER :: ios ! Local integer output status for namelist read
192	INTEGER :: inum
193	REAL(wp), POINTER, DIMENSION(:,:) :: zacs, zaos
194	!!
195	NAMELIST/namsbc_cpl/ sn_snd_temp, sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2, &
196	& sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr, &
197	& sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , sn_rcv_iceflx, &
198	& sn_rcv_co2 , nn_cplmodel , ln_usecplmask
199	!!---------------------------------------------------------------------
200	!
201	IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_init')
202	!
203	CALL wrk_alloc( jpi,jpj, zacs, zaos )
204
205	! ================================ !
206	! Namelist informations !
207	! ================================ !
208
209	REWIND( numnam_ref ) ! Namelist namsbc_cpl in reference namelist : Variables for OASIS coupling
210	READ ( numnam_ref, namsbc_cpl, IOSTAT = ios, ERR = 901)
211	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in reference namelist', lwp )
212
213	REWIND( numnam_cfg ) ! Namelist namsbc_cpl in configuration namelist : Variables for OASIS coupling
214	READ ( numnam_cfg, namsbc_cpl, IOSTAT = ios, ERR = 902 )
215	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in configuration namelist', lwp )
216	IF(lwm) WRITE ( numond, namsbc_cpl )
217
218	IF(lwp) THEN ! control print
219	WRITE(numout,*)
220	WRITE(numout,*)'sbc_cpl_init : namsbc_cpl namelist '
221	WRITE(numout,*)'~~~~~~~~~~~~'
222	WRITE(numout,*)' received fields (mutiple ice categogies)'
223	WRITE(numout,*)' 10m wind module = ', TRIM(sn_rcv_w10m%cldes ), ' (', TRIM(sn_rcv_w10m%clcat ), ')'
224	WRITE(numout,*)' stress module = ', TRIM(sn_rcv_taumod%cldes), ' (', TRIM(sn_rcv_taumod%clcat), ')'
225	WRITE(numout,*)' surface stress = ', TRIM(sn_rcv_tau%cldes ), ' (', TRIM(sn_rcv_tau%clcat ), ')'
226	WRITE(numout,*)' - referential = ', sn_rcv_tau%clvref
227	WRITE(numout,*)' - orientation = ', sn_rcv_tau%clvor
228	WRITE(numout,*)' - mesh = ', sn_rcv_tau%clvgrd
229	WRITE(numout,*)' non-solar heat flux sensitivity = ', TRIM(sn_rcv_dqnsdt%cldes), ' (', TRIM(sn_rcv_dqnsdt%clcat), ')'
230	WRITE(numout,*)' solar heat flux = ', TRIM(sn_rcv_qsr%cldes ), ' (', TRIM(sn_rcv_qsr%clcat ), ')'
231	WRITE(numout,*)' non-solar heat flux = ', TRIM(sn_rcv_qns%cldes ), ' (', TRIM(sn_rcv_qns%clcat ), ')'
232	WRITE(numout,*)' freshwater budget = ', TRIM(sn_rcv_emp%cldes ), ' (', TRIM(sn_rcv_emp%clcat ), ')'
233	WRITE(numout,*)' runoffs = ', TRIM(sn_rcv_rnf%cldes ), ' (', TRIM(sn_rcv_rnf%clcat ), ')'
234	WRITE(numout,*)' calving = ', TRIM(sn_rcv_cal%cldes ), ' (', TRIM(sn_rcv_cal%clcat ), ')'
235	WRITE(numout,*)' sea ice heat fluxes = ', TRIM(sn_rcv_iceflx%cldes), ' (', TRIM(sn_rcv_iceflx%clcat), ')'
236	WRITE(numout,*)' atm co2 = ', TRIM(sn_rcv_co2%cldes ), ' (', TRIM(sn_rcv_co2%clcat ), ')'
237	WRITE(numout,*)' sent fields (multiple ice categories)'
238	WRITE(numout,*)' surface temperature = ', TRIM(sn_snd_temp%cldes ), ' (', TRIM(sn_snd_temp%clcat ), ')'
239	WRITE(numout,*)' albedo = ', TRIM(sn_snd_alb%cldes ), ' (', TRIM(sn_snd_alb%clcat ), ')'
240	WRITE(numout,*)' ice/snow thickness = ', TRIM(sn_snd_thick%cldes ), ' (', TRIM(sn_snd_thick%clcat ), ')'
241	WRITE(numout,*)' surface current = ', TRIM(sn_snd_crt%cldes ), ' (', TRIM(sn_snd_crt%clcat ), ')'
242	WRITE(numout,*)' - referential = ', sn_snd_crt%clvref
243	WRITE(numout,*)' - orientation = ', sn_snd_crt%clvor
244	WRITE(numout,*)' - mesh = ', sn_snd_crt%clvgrd
245	WRITE(numout,*)' oce co2 flux = ', TRIM(sn_snd_co2%cldes ), ' (', TRIM(sn_snd_co2%clcat ), ')'
246	WRITE(numout,*)' nn_cplmodel = ', nn_cplmodel
247	WRITE(numout,*)' ln_usecplmask = ', ln_usecplmask
248	ENDIF
249
250	! ! allocate sbccpl arrays
251	!IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' )
252
253	! ================================ !
254	! Define the receive interface !
255	! ================================ !
256	nrcvinfo(:) = OASIS_idle ! needed by nrcvinfo(jpr_otx1) if we do not receive ocean stress
257
258	! for each field: define the OASIS name (srcv(:)%clname)
259	! define receive or not from the namelist parameters (srcv(:)%laction)
260	! define the north fold type of lbc (srcv(:)%nsgn)
261
262	! default definitions of srcv
263	srcv(:)%laction = .FALSE. ; srcv(:)%clgrid = 'T' ; srcv(:)%nsgn = 1. ; srcv(:)%nct = 1
264
265	! ! ------------------------- !
266	! ! ice and ocean wind stress !
267	! ! ------------------------- !
268	! ! Name
269	srcv(jpr_otx1)%clname = 'O_OTaux1' ! 1st ocean component on grid ONE (T or U)
270	srcv(jpr_oty1)%clname = 'O_OTauy1' ! 2nd - - - -
271	srcv(jpr_otz1)%clname = 'O_OTauz1' ! 3rd - - - -
272	srcv(jpr_otx2)%clname = 'O_OTaux2' ! 1st ocean component on grid TWO (V)
273	srcv(jpr_oty2)%clname = 'O_OTauy2' ! 2nd - - - -
274	srcv(jpr_otz2)%clname = 'O_OTauz2' ! 3rd - - - -
275	!
276	srcv(jpr_itx1)%clname = 'O_ITaux1' ! 1st ice component on grid ONE (T, F, I or U)
277	srcv(jpr_ity1)%clname = 'O_ITauy1' ! 2nd - - - -
278	srcv(jpr_itz1)%clname = 'O_ITauz1' ! 3rd - - - -
279	srcv(jpr_itx2)%clname = 'O_ITaux2' ! 1st ice component on grid TWO (V)
280	srcv(jpr_ity2)%clname = 'O_ITauy2' ! 2nd - - - -
281	srcv(jpr_itz2)%clname = 'O_ITauz2' ! 3rd - - - -
282	!
283	! Vectors: change of sign at north fold ONLY if on the local grid
284	IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) srcv(jpr_otx1:jpr_itz2)%nsgn = -1.
285
286	! ! Set grid and action
287	SELECT CASE( TRIM( sn_rcv_tau%clvgrd ) ) ! 'T', 'U,V', 'U,V,I', 'U,V,F', 'T,I', 'T,F', or 'T,U,V'
288	CASE( 'T' )
289	srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point
290	srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1
291	srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1
292	CASE( 'U,V' )
293	srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point
294	srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point
295	srcv(jpr_itx1:jpr_itz1)%clgrid = 'U' ! ice components given at U-point
296	srcv(jpr_itx2:jpr_itz2)%clgrid = 'V' ! and V-point
297	srcv(jpr_otx1:jpr_itz2)%laction = .TRUE. ! receive oce and ice components on both grid 1 & 2
298	CASE( 'U,V,T' )
299	srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point
300	srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point
301	srcv(jpr_itx1:jpr_itz1)%clgrid = 'T' ! ice components given at T-point
302	srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2
303	srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only
304	CASE( 'U,V,I' )
305	srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point
306	srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point
307	srcv(jpr_itx1:jpr_itz1)%clgrid = 'I' ! ice components given at I-point
308	srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2
309	srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only
310	CASE( 'U,V,F' )
311	srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point
312	srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point
313	srcv(jpr_itx1:jpr_itz1)%clgrid = 'F' ! ice components given at F-point
314	srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2
315	srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only
316	CASE( 'T,I' )
317	srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point
318	srcv(jpr_itx1:jpr_itz1)%clgrid = 'I' ! ice components given at I-point
319	srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1
320	srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1
321	CASE( 'T,F' )
322	srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point
323	srcv(jpr_itx1:jpr_itz1)%clgrid = 'F' ! ice components given at F-point
324	srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1
325	srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1
326	CASE( 'T,U,V' )
327	srcv(jpr_otx1:jpr_otz1)%clgrid = 'T' ! oce components given at T-point
328	srcv(jpr_itx1:jpr_itz1)%clgrid = 'U' ! ice components given at U-point
329	srcv(jpr_itx2:jpr_itz2)%clgrid = 'V' ! and V-point
330	srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 only
331	srcv(jpr_itx1:jpr_itz2)%laction = .TRUE. ! receive ice components on grid 1 & 2
332	CASE default
333	CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_tau%clvgrd' )
334	END SELECT
335	!
336	IF( TRIM( sn_rcv_tau%clvref ) == 'spherical' ) & ! spherical: 3rd component not received
337	& srcv( (/jpr_otz1, jpr_otz2, jpr_itz1, jpr_itz2/) )%laction = .FALSE.
338	!
339	IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) THEN ! already on local grid -> no need of the second grid
340	srcv(jpr_otx2:jpr_otz2)%laction = .FALSE.
341	srcv(jpr_itx2:jpr_itz2)%laction = .FALSE.
342	srcv(jpr_oty1)%clgrid = srcv(jpr_oty2)%clgrid ! not needed but cleaner...
343	srcv(jpr_ity1)%clgrid = srcv(jpr_ity2)%clgrid ! not needed but cleaner...
344	ENDIF
345	!
346	IF( TRIM( sn_rcv_tau%cldes ) /= 'oce and ice' ) THEN ! 'oce and ice' case ocean stress on ocean mesh used
347	srcv(jpr_itx1:jpr_itz2)%laction = .FALSE. ! ice components not received
348	srcv(jpr_itx1)%clgrid = 'U' ! ocean stress used after its transformation
349	srcv(jpr_ity1)%clgrid = 'V' ! i.e. it is always at U- & V-points for i- & j-comp. resp.
350	ENDIF
351
352	! ! ------------------------- !
353	! ! freshwater budget ! E-P
354	! ! ------------------------- !
355	! we suppose that atmosphere modele do not make the difference between precipiration (liquide or solid)
356	! over ice of free ocean within the same atmospheric cell.cd
357	srcv(jpr_rain)%clname = 'OTotRain' ! Rain = liquid precipitation
358	srcv(jpr_snow)%clname = 'OTotSnow' ! Snow = solid precipitation
359	srcv(jpr_tevp)%clname = 'OTotEvap' ! total evaporation (over oce + ice sublimation)
360	srcv(jpr_ievp)%clname = 'OIceEvap' ! evaporation over ice = sublimation
361	srcv(jpr_sbpr)%clname = 'OSubMPre' ! sublimation - liquid precipitation - solid precipitation
362	srcv(jpr_semp)%clname = 'OISubMSn' ! ice solid water budget = sublimation - solid precipitation
363	srcv(jpr_oemp)%clname = 'OOEvaMPr' ! ocean water budget = ocean Evap - ocean precip
364	SELECT CASE( TRIM( sn_rcv_emp%cldes ) )
365	CASE( 'oce only' ) ; srcv( jpr_oemp )%laction = .TRUE.
366	CASE( 'conservative' )
367	srcv( (/jpr_rain, jpr_snow, jpr_ievp, jpr_tevp/) )%laction = .TRUE.
368	IF ( k_ice <= 1 ) srcv(jpr_ievp)%laction = .FALSE.
369	CASE( 'oce and ice' ) ; srcv( (/jpr_ievp, jpr_sbpr, jpr_semp, jpr_oemp/) )%laction = .TRUE.
370	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_emp%cldes' )
371	END SELECT
372
373	! ! ------------------------- !
374	! ! Runoffs & Calving !
375	! ! ------------------------- !
376	srcv(jpr_rnf )%clname = 'O_Runoff' ; IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) srcv(jpr_rnf)%laction = .TRUE.
377	! This isn't right - really just want ln_rnf_emp changed
378	! IF( TRIM( sn_rcv_rnf%cldes ) == 'climato' ) THEN ; ln_rnf = .TRUE.
379	! ELSE ; ln_rnf = .FALSE.
380	! ENDIF
381	srcv(jpr_cal )%clname = 'OCalving' ; IF( TRIM( sn_rcv_cal%cldes ) == 'coupled' ) srcv(jpr_cal)%laction = .TRUE.
382
383	! ! ------------------------- !
384	! ! non solar radiation ! Qns
385	! ! ------------------------- !
386	srcv(jpr_qnsoce)%clname = 'O_QnsOce'
387	srcv(jpr_qnsice)%clname = 'O_QnsIce'
388	srcv(jpr_qnsmix)%clname = 'O_QnsMix'
389	SELECT CASE( TRIM( sn_rcv_qns%cldes ) )
390	CASE( 'oce only' ) ; srcv( jpr_qnsoce )%laction = .TRUE.
391	CASE( 'conservative' ) ; srcv( (/jpr_qnsice, jpr_qnsmix/) )%laction = .TRUE.
392	CASE( 'oce and ice' ) ; srcv( (/jpr_qnsice, jpr_qnsoce/) )%laction = .TRUE.
393	CASE( 'mixed oce-ice' ) ; srcv( jpr_qnsmix )%laction = .TRUE.
394	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qns%cldes' )
395	END SELECT
396	IF( TRIM( sn_rcv_qns%cldes ) == 'mixed oce-ice' .AND. jpl > 1 ) &
397	CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qns%cldes not currently allowed to be mixed oce-ice for multi-category ice' )
398	! ! ------------------------- !
399	! ! solar radiation ! Qsr
400	! ! ------------------------- !
401	srcv(jpr_qsroce)%clname = 'O_QsrOce'
402	srcv(jpr_qsrice)%clname = 'O_QsrIce'
403	srcv(jpr_qsrmix)%clname = 'O_QsrMix'
404	SELECT CASE( TRIM( sn_rcv_qsr%cldes ) )
405	CASE( 'oce only' ) ; srcv( jpr_qsroce )%laction = .TRUE.
406	CASE( 'conservative' ) ; srcv( (/jpr_qsrice, jpr_qsrmix/) )%laction = .TRUE.
407	CASE( 'oce and ice' ) ; srcv( (/jpr_qsrice, jpr_qsroce/) )%laction = .TRUE.
408	CASE( 'mixed oce-ice' ) ; srcv( jpr_qsrmix )%laction = .TRUE.
409	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qsr%cldes' )
410	END SELECT
411	IF( TRIM( sn_rcv_qsr%cldes ) == 'mixed oce-ice' .AND. jpl > 1 ) &
412	CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qsr%cldes not currently allowed to be mixed oce-ice for multi-category ice' )
413	! ! ------------------------- !
414	! ! non solar sensitivity ! d(Qns)/d(T)
415	! ! ------------------------- !
416	srcv(jpr_dqnsdt)%clname = 'O_dQnsdT'
417	IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'coupled' ) srcv(jpr_dqnsdt)%laction = .TRUE.
418	!
419	! non solar sensitivity mandatory for LIM ice model
420	IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. k_ice /= 0 .AND. k_ice /= 4) &
421	CALL ctl_stop( 'sbc_cpl_init: sn_rcv_dqnsdt%cldes must be coupled in namsbc_cpl namelist' )
422	! non solar sensitivity mandatory for mixed oce-ice solar radiation coupling technique
423	IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. TRIM( sn_rcv_qns%cldes ) == 'mixed oce-ice' ) &
424	CALL ctl_stop( 'sbc_cpl_init: namsbc_cpl namelist mismatch between sn_rcv_qns%cldes and sn_rcv_dqnsdt%cldes' )
425	! ! ------------------------- !
426	! ! 10m wind module !
427	! ! ------------------------- !
428	srcv(jpr_w10m)%clname = 'O_Wind10' ; IF( TRIM(sn_rcv_w10m%cldes ) == 'coupled' ) srcv(jpr_w10m)%laction = .TRUE.
429	!
430	! ! ------------------------- !
431	! ! wind stress module !
432	! ! ------------------------- !
433	srcv(jpr_taum)%clname = 'O_TauMod' ; IF( TRIM(sn_rcv_taumod%cldes) == 'coupled' ) srcv(jpr_taum)%laction = .TRUE.
434	lhftau = srcv(jpr_taum)%laction
435
436	! ! ------------------------- !
437	! ! Atmospheric CO2 !
438	! ! ------------------------- !
439	srcv(jpr_co2 )%clname = 'O_AtmCO2' ; IF( TRIM(sn_rcv_co2%cldes ) == 'coupled' ) srcv(jpr_co2 )%laction = .TRUE.
440	! ! ------------------------- !
441	! ! topmelt and botmelt !
442	! ! ------------------------- !
443	srcv(jpr_topm )%clname = 'OTopMlt'
444	srcv(jpr_botm )%clname = 'OBotMlt'
445	IF( TRIM(sn_rcv_iceflx%cldes) == 'coupled' ) THEN
446	IF ( TRIM( sn_rcv_iceflx%clcat ) == 'yes' ) THEN
447	srcv(jpr_topm:jpr_botm)%nct = jpl
448	ELSE
449	CALL ctl_stop( 'sbc_cpl_init: sn_rcv_iceflx%clcat should always be set to yes currently' )
450	ENDIF
451	srcv(jpr_topm:jpr_botm)%laction = .TRUE.
452	ENDIF
453
454	! Allocate all parts of frcv used for received fields
455	DO jn = 1, jprcv
456	IF ( srcv(jn)%laction ) ALLOCATE( frcv(jn)%z3(jpi,jpj,srcv(jn)%nct) )
457	END DO
458	! Allocate taum part of frcv which is used even when not received as coupling field
459	IF ( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(jpi,jpj,srcv(jpr_taum)%nct) )
460	! Allocate itx1 and ity1 as they are used in sbc_cpl_ice_tau even if srcv(jpr_itx1)%laction = .FALSE.
461	IF( k_ice /= 0 ) THEN
462	IF ( .NOT. srcv(jpr_itx1)%laction ) ALLOCATE( frcv(jpr_itx1)%z3(jpi,jpj,srcv(jpr_itx1)%nct) )
463	IF ( .NOT. srcv(jpr_ity1)%laction ) ALLOCATE( frcv(jpr_ity1)%z3(jpi,jpj,srcv(jpr_ity1)%nct) )
464	END IF
465
466	! ================================ !
467	! Define the send interface !
468	! ================================ !
469	! for each field: define the OASIS name (ssnd(:)%clname)
470	! define send or not from the namelist parameters (ssnd(:)%laction)
471	! define the north fold type of lbc (ssnd(:)%nsgn)
472
473	! default definitions of nsnd
474	ssnd(:)%laction = .FALSE. ; ssnd(:)%clgrid = 'T' ; ssnd(:)%nsgn = 1. ; ssnd(:)%nct = 1
475
476	! ! ------------------------- !
477	! ! Surface temperature !
478	! ! ------------------------- !
479	ssnd(jps_toce)%clname = 'O_SSTSST'
480	ssnd(jps_tice)%clname = 'O_TepIce'
481	ssnd(jps_tmix)%clname = 'O_TepMix'
482	SELECT CASE( TRIM( sn_snd_temp%cldes ) )
483	CASE( 'none' ) ! nothing to do
484	CASE( 'oce only' ) ; ssnd( jps_toce )%laction = .TRUE.
485	CASE( 'weighted oce and ice' )
486	ssnd( (/jps_toce, jps_tice/) )%laction = .TRUE.
487	IF ( TRIM( sn_snd_temp%clcat ) == 'yes' ) ssnd(jps_tice)%nct = jpl
488	CASE( 'mixed oce-ice' ) ; ssnd( jps_tmix )%laction = .TRUE.
489	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_temp%cldes' )
490	END SELECT
491
492	! ! ------------------------- !
493	! ! Albedo !
494	! ! ------------------------- !
495	ssnd(jps_albice)%clname = 'O_AlbIce'
496	ssnd(jps_albmix)%clname = 'O_AlbMix'
497	SELECT CASE( TRIM( sn_snd_alb%cldes ) )
498	CASE( 'none' ) ! nothing to do
499	CASE( 'weighted ice' ) ; ssnd(jps_albice)%laction = .TRUE.
500	CASE( 'mixed oce-ice' ) ; ssnd(jps_albmix)%laction = .TRUE.
501	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_alb%cldes' )
502	END SELECT
503	!
504	! Need to calculate oceanic albedo if
505	! 1. sending mixed oce-ice albedo or
506	! 2. receiving mixed oce-ice solar radiation
507	IF ( TRIM ( sn_snd_alb%cldes ) == 'mixed oce-ice' .OR. TRIM ( sn_rcv_qsr%cldes ) == 'mixed oce-ice' ) THEN
508	CALL albedo_oce( zaos, zacs )
509	! Due to lack of information on nebulosity : mean clear/overcast sky
510	albedo_oce_mix(:,:) = ( zacs(:,:) + zaos(:,:) ) * 0.5
511	ENDIF
512
513	! ! ------------------------- !
514	! ! Ice fraction & Thickness !
515	! ! ------------------------- !
516	ssnd(jps_fice)%clname = 'OIceFrc'
517	ssnd(jps_hice)%clname = 'OIceTck'
518	ssnd(jps_hsnw)%clname = 'OSnwTck'
519	IF( k_ice /= 0 ) THEN
520	ssnd(jps_fice)%laction = .TRUE. ! if ice treated in the ocean (even in climato case)
521	! Currently no namelist entry to determine sending of multi-category ice fraction so use the thickness entry for now
522	IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_fice)%nct = jpl
523	ENDIF
524
525	SELECT CASE ( TRIM( sn_snd_thick%cldes ) )
526	CASE( 'none' ) ! nothing to do
527	CASE( 'ice and snow' )
528	ssnd(jps_hice:jps_hsnw)%laction = .TRUE.
529	IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) THEN
530	ssnd(jps_hice:jps_hsnw)%nct = jpl
531	ELSE
532	IF ( jpl > 1 ) THEN
533	CALL ctl_stop( 'sbc_cpl_init: use weighted ice and snow option for sn_snd_thick%cldes if not exchanging category fields' )
534	ENDIF
535	ENDIF
536	CASE ( 'weighted ice and snow' )
537	ssnd(jps_hice:jps_hsnw)%laction = .TRUE.
538	IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_hice:jps_hsnw)%nct = jpl
539	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_thick%cldes' )
540	END SELECT
541
542	! ! ------------------------- !
543	! ! Surface current !
544	! ! ------------------------- !
545	! ocean currents ! ice velocities
546	ssnd(jps_ocx1)%clname = 'O_OCurx1' ; ssnd(jps_ivx1)%clname = 'O_IVelx1'
547	ssnd(jps_ocy1)%clname = 'O_OCury1' ; ssnd(jps_ivy1)%clname = 'O_IVely1'
548	ssnd(jps_ocz1)%clname = 'O_OCurz1' ; ssnd(jps_ivz1)%clname = 'O_IVelz1'
549	!
550	ssnd(jps_ocx1:jps_ivz1)%nsgn = -1. ! vectors: change of the sign at the north fold
551
552	IF( sn_snd_crt%clvgrd == 'U,V' ) THEN
553	ssnd(jps_ocx1)%clgrid = 'U' ; ssnd(jps_ocy1)%clgrid = 'V'
554	ELSE IF( sn_snd_crt%clvgrd /= 'T' ) THEN
555	CALL ctl_stop( 'sn_snd_crt%clvgrd must be equal to T' )
556	ssnd(jps_ocx1:jps_ivz1)%clgrid = 'T' ! all oce and ice components on the same unique grid
557	ENDIF
558	ssnd(jps_ocx1:jps_ivz1)%laction = .TRUE. ! default: all are send
559	IF( TRIM( sn_snd_crt%clvref ) == 'spherical' ) ssnd( (/jps_ocz1, jps_ivz1/) )%laction = .FALSE.
560	IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) ssnd(jps_ocx1:jps_ivz1)%nsgn = 1.
561	SELECT CASE( TRIM( sn_snd_crt%cldes ) )
562	CASE( 'none' ) ; ssnd(jps_ocx1:jps_ivz1)%laction = .FALSE.
563	CASE( 'oce only' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE.
564	CASE( 'weighted oce and ice' ) ! nothing to do
565	CASE( 'mixed oce-ice' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE.
566	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_crt%cldes' )
567	END SELECT
568
569	! ! ------------------------- !
570	! ! CO2 flux !
571	! ! ------------------------- !
572	ssnd(jps_co2)%clname = 'O_CO2FLX' ; IF( TRIM(sn_snd_co2%cldes) == 'coupled' ) ssnd(jps_co2 )%laction = .TRUE.
573	!
574	! ================================ !
575	! initialisation of the coupler !
576	! ================================ !
577
578	CALL cpl_define(jprcv, jpsnd,nn_cplmodel)
579	IF (ln_usecplmask) THEN
580	xcplmask(:,:,:) = 0.
581	CALL iom_open( 'cplmask', inum )
582	CALL iom_get( inum, jpdom_unknown, 'cplmask', xcplmask(1:nlci,1:nlcj,1:nn_cplmodel), &
583	& kstart = (/ mig(1),mjg(1),1 /), kcount = (/ nlci,nlcj,nn_cplmodel /) )
584	CALL iom_close( inum )
585	ELSE
586	xcplmask(:,:,:) = 1.
587	ENDIF
588	!
589	IF( ln_dm2dc .AND. ( cpl_freq( jpr_qsroce ) + cpl_freq( jpr_qsrmix ) /= 86400 ) ) &
590	& CALL ctl_stop( 'sbc_cpl_init: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' )
591
592	CALL wrk_dealloc( jpi,jpj, zacs, zaos )
593	!
594	IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_init')
595	!
596	END SUBROUTINE sbc_cpl_init
597
598
599	SUBROUTINE sbc_cpl_rcv( kt, k_fsbc, k_ice )
600	!!----------------------------------------------------------------------
601	!! * ROUTINE sbc_cpl_rcv *
602	!!
603	!! ** Purpose : provide the stress over the ocean and, if no sea-ice,
604	!! provide the ocean heat and freshwater fluxes.
605	!!
606	!! ** Method : - Receive all the atmospheric fields (stored in frcv array). called at each time step.
607	!! OASIS controls if there is something do receive or not. nrcvinfo contains the info
608	!! to know if the field was really received or not
609	!!
610	!! --> If ocean stress was really received:
611	!!
612	!! - transform the received ocean stress vector from the received
613	!! referential and grid into an atmosphere-ocean stress in
614	!! the (i,j) ocean referencial and at the ocean velocity point.
615	!! The received stress are :
616	!! - defined by 3 components (if cartesian coordinate)
617	!! or by 2 components (if spherical)
618	!! - oriented along geographical coordinate (if eastward-northward)
619	!! or along the local grid coordinate (if local grid)
620	!! - given at U- and V-point, resp. if received on 2 grids
621	!! or at T-point if received on 1 grid
622	!! Therefore and if necessary, they are successively
623	!! processed in order to obtain them
624	!! first as 2 components on the sphere
625	!! second as 2 components oriented along the local grid
626	!! third as 2 components on the U,V grid
627	!!
628	!! -->
629	!!
630	!! - In 'ocean only' case, non solar and solar ocean heat fluxes
631	!! and total ocean freshwater fluxes
632	!!
633	!! ** Method : receive all fields from the atmosphere and transform
634	!! them into ocean surface boundary condition fields
635	!!
636	!! ** Action : update utau, vtau ocean stress at U,V grid
637	!! taum wind stress module at T-point
638	!! wndm wind speed module at T-point over free ocean or leads in presence of sea-ice
639	!! qns non solar heat fluxes including emp heat content (ocean only case)
640	!! and the latent heat flux of solid precip. melting
641	!! qsr solar ocean heat fluxes (ocean only case)
642	!! emp upward mass flux [evap. - precip. (- runoffs) (- calving)] (ocean only case)
643	!!----------------------------------------------------------------------
644	INTEGER, INTENT(in) :: kt ! ocean model time step index
645	INTEGER, INTENT(in) :: k_fsbc ! frequency of sbc (-> ice model) computation
646	INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3)
647	!!
648	LOGICAL :: llnewtx, llnewtau ! update wind stress components and module??
649	INTEGER :: ji, jj, jn ! dummy loop indices
650	INTEGER :: isec ! number of seconds since nit000 (assuming rdttra did not change since nit000)
651	REAL(wp) :: zcumulneg, zcumulpos ! temporary scalars
652	REAL(wp) :: zcoef ! temporary scalar
653	REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3
654	REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient
655	REAL(wp) :: zzx, zzy ! temporary variables
656	REAL(wp), POINTER, DIMENSION(:,:) :: ztx, zty
657	!!----------------------------------------------------------------------
658	!
659	IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_rcv')
660	!
661	CALL wrk_alloc( jpi,jpj, ztx, zty )
662	! ! Receive all the atmos. fields (including ice information)
663	isec = ( kt - nit000 ) * NINT( rdttra(1) ) ! date of exchanges
664	DO jn = 1, jprcv ! received fields sent by the atmosphere
665	IF( srcv(jn)%laction ) CALL cpl_rcv( jn, isec, frcv(jn)%z3, xcplmask, nrcvinfo(jn) )
666	END DO
667
668	! ! ========================= !
669	IF( srcv(jpr_otx1)%laction ) THEN ! ocean stress components !
670	! ! ========================= !
671	! define frcv(jpr_otx1)%z3(:,:,1) and frcv(jpr_oty1)%z3(:,:,1): stress at U/V point along model grid
672	! => need to be done only when we receive the field
673	IF( nrcvinfo(jpr_otx1) == OASIS_Rcv ) THEN
674	!
675	IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere
676	! ! (cartesian to spherical -> 3 to 2 components)
677	!
678	CALL geo2oce( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), frcv(jpr_otz1)%z3(:,:,1), &
679	& srcv(jpr_otx1)%clgrid, ztx, zty )
680	frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid
681	frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid
682	!
683	IF( srcv(jpr_otx2)%laction ) THEN
684	CALL geo2oce( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), frcv(jpr_otz2)%z3(:,:,1), &
685	& srcv(jpr_otx2)%clgrid, ztx, zty )
686	frcv(jpr_otx2)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid
687	frcv(jpr_oty2)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 2nd grid
688	ENDIF
689	!
690	ENDIF
691	!
692	IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid
693	! ! (geographical to local grid -> rotate the components)
694	CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx )
695	IF( srcv(jpr_otx2)%laction ) THEN
696	CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty )
697	ELSE
698	CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty )
699	ENDIF
700	frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid
701	frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 2nd grid
702	ENDIF
703	!
704	IF( srcv(jpr_otx1)%clgrid == 'T' ) THEN
705	DO jj = 2, jpjm1 ! T ==> (U,V)
706	DO ji = fs_2, fs_jpim1 ! vector opt.
707	frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) )
708	frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) )
709	END DO
710	END DO
711	CALL lbc_lnk( frcv(jpr_otx1)%z3(:,:,1), 'U', -1. ) ; CALL lbc_lnk( frcv(jpr_oty1)%z3(:,:,1), 'V', -1. )
712	ENDIF
713	llnewtx = .TRUE.
714	ELSE
715	llnewtx = .FALSE.
716	ENDIF
717	! ! ========================= !
718	ELSE ! No dynamical coupling !
719	! ! ========================= !
720	frcv(jpr_otx1)%z3(:,:,1) = 0.e0 ! here simply set to zero
721	frcv(jpr_oty1)%z3(:,:,1) = 0.e0 ! an external read in a file can be added instead
722	llnewtx = .TRUE.
723	!
724	ENDIF
725
726	! ! ========================= !
727	! ! wind stress module ! (taum)
728	! ! ========================= !
729	!
730	IF( .NOT. srcv(jpr_taum)%laction ) THEN ! compute wind stress module from its components if not received
731	! => need to be done only when otx1 was changed
732	IF( llnewtx ) THEN
733	!CDIR NOVERRCHK
734	DO jj = 2, jpjm1
735	!CDIR NOVERRCHK
736	DO ji = fs_2, fs_jpim1 ! vect. opt.
737	zzx = frcv(jpr_otx1)%z3(ji-1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1)
738	zzy = frcv(jpr_oty1)%z3(ji ,jj-1,1) + frcv(jpr_oty1)%z3(ji,jj,1)
739	frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy )
740	END DO
741	END DO
742	CALL lbc_lnk( frcv(jpr_taum)%z3(:,:,1), 'T', 1. )
743	llnewtau = .TRUE.
744	ELSE
745	llnewtau = .FALSE.
746	ENDIF
747	ELSE
748	llnewtau = nrcvinfo(jpr_taum) == OASIS_Rcv
749	! Stress module can be negative when received (interpolation problem)
750	IF( llnewtau ) THEN
751	frcv(jpr_taum)%z3(:,:,1) = MAX( 0._wp, frcv(jpr_taum)%z3(:,:,1) )
752	ENDIF
753	ENDIF
754
755	! ! ========================= !
756	! ! 10 m wind speed ! (wndm)
757	! ! ========================= !
758	!
759	IF( .NOT. srcv(jpr_w10m)%laction ) THEN ! compute wind spreed from wind stress module if not received
760	! => need to be done only when taumod was changed
761	IF( llnewtau ) THEN
762	zcoef = 1. / ( zrhoa * zcdrag )
763	!CDIR NOVERRCHK
764	DO jj = 1, jpj
765	!CDIR NOVERRCHK
766	DO ji = 1, jpi
767	wndm(ji,jj) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef )
768	END DO
769	END DO
770	ENDIF
771	ELSE
772	IF ( nrcvinfo(jpr_w10m) == OASIS_Rcv ) wndm(:,:) = frcv(jpr_w10m)%z3(:,:,1)
773	ENDIF
774
775	! u(v)tau and taum will be modified by ice model
776	! -> need to be reset before each call of the ice/fsbc
777	IF( MOD( kt-1, k_fsbc ) == 0 ) THEN
778	!
779	utau(:,:) = frcv(jpr_otx1)%z3(:,:,1)
780	vtau(:,:) = frcv(jpr_oty1)%z3(:,:,1)
781	taum(:,:) = frcv(jpr_taum)%z3(:,:,1)
782	CALL iom_put( "taum_oce", taum ) ! output wind stress module
783	!
784	ENDIF
785
786	#if defined key_cpl_carbon_cycle
787	! ! atmosph. CO2 (ppm)
788	IF( srcv(jpr_co2)%laction ) atm_co2(:,:) = frcv(jpr_co2)%z3(:,:,1)
789	#endif
790
791	! ! ========================= !
792	IF( k_ice <= 1 ) THEN ! heat & freshwater fluxes ! (Ocean only case)
793	! ! ========================= !
794	!
795	! ! total freshwater fluxes over the ocean (emp)
796	SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) ! evaporation - precipitation
797	CASE( 'conservative' )
798	emp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ( frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1) )
799	CASE( 'oce only', 'oce and ice' )
800	emp(:,:) = frcv(jpr_oemp)%z3(:,:,1)
801	CASE default
802	CALL ctl_stop( 'sbc_cpl_rcv: wrong definition of sn_rcv_emp%cldes' )
803	END SELECT
804	!
805	! ! runoffs and calving (added in emp)
806	IF( srcv(jpr_rnf)%laction ) emp(:,:) = emp(:,:) - frcv(jpr_rnf)%z3(:,:,1)
807	IF( srcv(jpr_cal)%laction ) emp(:,:) = emp(:,:) - frcv(jpr_cal)%z3(:,:,1)
808	!
809	!!gm : this seems to be internal cooking, not sure to need that in a generic interface
810	!!gm at least should be optional...
811	!! IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN ! add to the total freshwater budget
812	!! ! remove negative runoff
813	!! zcumulpos = SUM( MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )
814	!! zcumulneg = SUM( MIN( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )
815	!! IF( lk_mpp ) CALL mpp_sum( zcumulpos ) ! sum over the global domain
816	!! IF( lk_mpp ) CALL mpp_sum( zcumulneg )
817	!! IF( zcumulpos /= 0. ) THEN ! distribute negative runoff on positive runoff grid points
818	!! zcumulneg = 1.e0 + zcumulneg / zcumulpos
819	!! frcv(jpr_rnf)%z3(:,:,1) = MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * zcumulneg
820	!! ENDIF
821	!! ! add runoff to e-p
822	!! emp(:,:) = emp(:,:) - frcv(jpr_rnf)%z3(:,:,1)
823	!! ENDIF
824	!!gm end of internal cooking
825	!
826	! ! non solar heat flux over the ocean (qns)
827	IF( srcv(jpr_qnsoce)%laction ) qns(:,:) = frcv(jpr_qnsoce)%z3(:,:,1)
828	IF( srcv(jpr_qnsmix)%laction ) qns(:,:) = frcv(jpr_qnsmix)%z3(:,:,1)
829	! update qns over the free ocean with:
830	qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! remove heat content due to mass flux (assumed to be at SST)
831	IF( srcv(jpr_snow )%laction ) THEN
832	qns(:,:) = qns(:,:) - frcv(jpr_snow)%z3(:,:,1) * lfus ! energy for melting solid precipitation over the free ocean
833	ENDIF
834
835	! ! solar flux over the ocean (qsr)
836	IF( srcv(jpr_qsroce)%laction ) qsr(:,:) = frcv(jpr_qsroce)%z3(:,:,1)
837	IF( srcv(jpr_qsrmix)%laction ) qsr(:,:) = frcv(jpr_qsrmix)%z3(:,:,1)
838	IF( ln_dm2dc ) qsr(:,:) = sbc_dcy( qsr ) ! modify qsr to include the diurnal cycle
839	!
840
841	ENDIF
842	!
843	CALL wrk_dealloc( jpi,jpj, ztx, zty )
844	!
845	IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_rcv')
846	!
847	END SUBROUTINE sbc_cpl_rcv
848
849
850	SUBROUTINE sbc_cpl_ice_tau( p_taui, p_tauj )
851	!!----------------------------------------------------------------------
852	!! * ROUTINE sbc_cpl_ice_tau *
853	!!
854	!! ** Purpose : provide the stress over sea-ice in coupled mode
855	!!
856	!! ** Method : transform the received stress from the atmosphere into
857	!! an atmosphere-ice stress in the (i,j) ocean referencial
858	!! and at the velocity point of the sea-ice model (cp_ice_msh):
859	!! 'C'-grid : i- (j-) components given at U- (V-) point
860	!! 'I'-grid : B-grid lower-left corner: both components given at I-point
861	!!
862	!! The received stress are :
863	!! - defined by 3 components (if cartesian coordinate)
864	!! or by 2 components (if spherical)
865	!! - oriented along geographical coordinate (if eastward-northward)
866	!! or along the local grid coordinate (if local grid)
867	!! - given at U- and V-point, resp. if received on 2 grids
868	!! or at a same point (T or I) if received on 1 grid
869	!! Therefore and if necessary, they are successively
870	!! processed in order to obtain them
871	!! first as 2 components on the sphere
872	!! second as 2 components oriented along the local grid
873	!! third as 2 components on the cp_ice_msh point
874	!!
875	!! Except in 'oce and ice' case, only one vector stress field
876	!! is received. It has already been processed in sbc_cpl_rcv
877	!! so that it is now defined as (i,j) components given at U-
878	!! and V-points, respectively. Therefore, only the third
879	!! transformation is done and only if the ice-grid is a 'I'-grid.
880	!!
881	!! ** Action : return ptau_i, ptau_j, the stress over the ice at cp_ice_msh point
882	!!----------------------------------------------------------------------
883	REAL(wp), INTENT(out), DIMENSION(:,:) :: p_taui ! i- & j-components of atmos-ice stress [N/m2]
884	REAL(wp), INTENT(out), DIMENSION(:,:) :: p_tauj ! at I-point (B-grid) or U & V-point (C-grid)
885	!!
886	INTEGER :: ji, jj ! dummy loop indices
887	INTEGER :: itx ! index of taux over ice
888	REAL(wp), POINTER, DIMENSION(:,:) :: ztx, zty
889	!!----------------------------------------------------------------------
890	!
891	IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_ice_tau')
892	!
893	CALL wrk_alloc( jpi,jpj, ztx, zty )
894
895	IF( srcv(jpr_itx1)%laction ) THEN ; itx = jpr_itx1
896	ELSE ; itx = jpr_otx1
897	ENDIF
898
899	! do something only if we just received the stress from atmosphere
900	IF( nrcvinfo(itx) == OASIS_Rcv ) THEN
901
902	! ! ======================= !
903	IF( srcv(jpr_itx1)%laction ) THEN ! ice stress received !
904	! ! ======================= !
905	!
906	IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere
907	! ! (cartesian to spherical -> 3 to 2 components)
908	CALL geo2oce( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), frcv(jpr_itz1)%z3(:,:,1), &
909	& srcv(jpr_itx1)%clgrid, ztx, zty )
910	frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid
911	frcv(jpr_ity1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid
912	!
913	IF( srcv(jpr_itx2)%laction ) THEN
914	CALL geo2oce( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), frcv(jpr_itz2)%z3(:,:,1), &
915	& srcv(jpr_itx2)%clgrid, ztx, zty )
916	frcv(jpr_itx2)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid
917	frcv(jpr_ity2)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 2nd grid
918	ENDIF
919	!
920	ENDIF
921	!
922	IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid
923	! ! (geographical to local grid -> rotate the components)
924	CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->i', ztx )
925	IF( srcv(jpr_itx2)%laction ) THEN
926	CALL rot_rep( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), srcv(jpr_itx2)%clgrid, 'en->j', zty )
927	ELSE
928	CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->j', zty )
929	ENDIF
930	frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid
931	frcv(jpr_ity1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 1st grid
932	ENDIF
933	! ! ======================= !
934	ELSE ! use ocean stress !
935	! ! ======================= !
936	frcv(jpr_itx1)%z3(:,:,1) = frcv(jpr_otx1)%z3(:,:,1)
937	frcv(jpr_ity1)%z3(:,:,1) = frcv(jpr_oty1)%z3(:,:,1)
938	!
939	ENDIF
940
941	! ! ======================= !
942	! ! put on ice grid !
943	! ! ======================= !
944	!
945	! j+1 j -----V---F
946	! ice stress on ice velocity point (cp_ice_msh) ! \|
947	! (C-grid ==>(U,V) or B-grid ==> I or F) j \| T U
948	! \| \|
949	! j j-1 -I-------\|
950	! (for I) \| \|
951	! i-1 i i
952	! i i+1 (for I)
953	SELECT CASE ( cp_ice_msh )
954	!
955	CASE( 'I' ) ! B-grid ==> I
956	SELECT CASE ( srcv(jpr_itx1)%clgrid )
957	CASE( 'U' )
958	DO jj = 2, jpjm1 ! (U,V) ==> I
959	DO ji = 2, jpim1 ! NO vector opt.
960	p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji-1,jj ,1) + frcv(jpr_itx1)%z3(ji-1,jj-1,1) )
961	p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji ,jj-1,1) + frcv(jpr_ity1)%z3(ji-1,jj-1,1) )
962	END DO
963	END DO
964	CASE( 'F' )
965	DO jj = 2, jpjm1 ! F ==> I
966	DO ji = 2, jpim1 ! NO vector opt.
967	p_taui(ji,jj) = frcv(jpr_itx1)%z3(ji-1,jj-1,1)
968	p_tauj(ji,jj) = frcv(jpr_ity1)%z3(ji-1,jj-1,1)
969	END DO
970	END DO
971	CASE( 'T' )
972	DO jj = 2, jpjm1 ! T ==> I
973	DO ji = 2, jpim1 ! NO vector opt.
974	p_taui(ji,jj) = 0.25 * ( frcv(jpr_itx1)%z3(ji,jj ,1) + frcv(jpr_itx1)%z3(ji-1,jj ,1) &
975	& + frcv(jpr_itx1)%z3(ji,jj-1,1) + frcv(jpr_itx1)%z3(ji-1,jj-1,1) )
976	p_tauj(ji,jj) = 0.25 * ( frcv(jpr_ity1)%z3(ji,jj ,1) + frcv(jpr_ity1)%z3(ji-1,jj ,1) &
977	& + frcv(jpr_oty1)%z3(ji,jj-1,1) + frcv(jpr_ity1)%z3(ji-1,jj-1,1) )
978	END DO
979	END DO
980	CASE( 'I' )
981	p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1) ! I ==> I
982	p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1)
983	END SELECT
984	IF( srcv(jpr_itx1)%clgrid /= 'I' ) THEN
985	CALL lbc_lnk( p_taui, 'I', -1. ) ; CALL lbc_lnk( p_tauj, 'I', -1. )
986	ENDIF
987	!
988	CASE( 'F' ) ! B-grid ==> F
989	SELECT CASE ( srcv(jpr_itx1)%clgrid )
990	CASE( 'U' )
991	DO jj = 2, jpjm1 ! (U,V) ==> F
992	DO ji = fs_2, fs_jpim1 ! vector opt.
993	p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji,jj,1) + frcv(jpr_itx1)%z3(ji ,jj+1,1) )
994	p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji,jj,1) + frcv(jpr_ity1)%z3(ji+1,jj ,1) )
995	END DO
996	END DO
997	CASE( 'I' )
998	DO jj = 2, jpjm1 ! I ==> F
999	DO ji = 2, jpim1 ! NO vector opt.
1000	p_taui(ji,jj) = frcv(jpr_itx1)%z3(ji+1,jj+1,1)
1001	p_tauj(ji,jj) = frcv(jpr_ity1)%z3(ji+1,jj+1,1)
1002	END DO
1003	END DO
1004	CASE( 'T' )
1005	DO jj = 2, jpjm1 ! T ==> F
1006	DO ji = 2, jpim1 ! NO vector opt.
1007	p_taui(ji,jj) = 0.25 * ( frcv(jpr_itx1)%z3(ji,jj ,1) + frcv(jpr_itx1)%z3(ji+1,jj ,1) &
1008	& + frcv(jpr_itx1)%z3(ji,jj+1,1) + frcv(jpr_itx1)%z3(ji+1,jj+1,1) )
1009	p_tauj(ji,jj) = 0.25 * ( frcv(jpr_ity1)%z3(ji,jj ,1) + frcv(jpr_ity1)%z3(ji+1,jj ,1) &
1010	& + frcv(jpr_ity1)%z3(ji,jj+1,1) + frcv(jpr_ity1)%z3(ji+1,jj+1,1) )
1011	END DO
1012	END DO
1013	CASE( 'F' )
1014	p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1) ! F ==> F
1015	p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1)
1016	END SELECT
1017	IF( srcv(jpr_itx1)%clgrid /= 'F' ) THEN
1018	CALL lbc_lnk( p_taui, 'F', -1. ) ; CALL lbc_lnk( p_tauj, 'F', -1. )
1019	ENDIF
1020	!
1021	CASE( 'C' ) ! C-grid ==> U,V
1022	SELECT CASE ( srcv(jpr_itx1)%clgrid )
1023	CASE( 'U' )
1024	p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1) ! (U,V) ==> (U,V)
1025	p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1)
1026	CASE( 'F' )
1027	DO jj = 2, jpjm1 ! F ==> (U,V)
1028	DO ji = fs_2, fs_jpim1 ! vector opt.
1029	p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji,jj,1) + frcv(jpr_itx1)%z3(ji ,jj-1,1) )
1030	p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(jj,jj,1) + frcv(jpr_ity1)%z3(ji-1,jj ,1) )
1031	END DO
1032	END DO
1033	CASE( 'T' )
1034	DO jj = 2, jpjm1 ! T ==> (U,V)
1035	DO ji = fs_2, fs_jpim1 ! vector opt.
1036	p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji+1,jj ,1) + frcv(jpr_itx1)%z3(ji,jj,1) )
1037	p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) )
1038	END DO
1039	END DO
1040	CASE( 'I' )
1041	DO jj = 2, jpjm1 ! I ==> (U,V)
1042	DO ji = 2, jpim1 ! NO vector opt.
1043	p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji+1,jj+1,1) + frcv(jpr_itx1)%z3(ji+1,jj ,1) )
1044	p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji+1,jj+1,1) + frcv(jpr_ity1)%z3(ji ,jj+1,1) )
1045	END DO
1046	END DO
1047	END SELECT
1048	IF( srcv(jpr_itx1)%clgrid /= 'U' ) THEN
1049	CALL lbc_lnk( p_taui, 'U', -1. ) ; CALL lbc_lnk( p_tauj, 'V', -1. )
1050	ENDIF
1051	END SELECT
1052
1053	ENDIF
1054	!
1055	CALL wrk_dealloc( jpi,jpj, ztx, zty )
1056	!
1057	IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_ice_tau')
1058	!
1059	END SUBROUTINE sbc_cpl_ice_tau
1060
1061
1062	SUBROUTINE sbc_cpl_ice_flx( p_frld , palbi , psst , pist )
1063	!!----------------------------------------------------------------------
1064	!! * ROUTINE sbc_cpl_ice_flx *
1065	!!
1066	!! ** Purpose : provide the heat and freshwater fluxes of the
1067	!! ocean-ice system.
1068	!!
1069	!! ** Method : transform the fields received from the atmosphere into
1070	!! surface heat and fresh water boundary condition for the
1071	!! ice-ocean system. The following fields are provided:
1072	!! * total non solar, solar and freshwater fluxes (qns_tot,
1073	!! qsr_tot and emp_tot) (total means weighted ice-ocean flux)
1074	!! NB: emp_tot include runoffs and calving.
1075	!! * fluxes over ice (qns_ice, qsr_ice, emp_ice) where
1076	!! emp_ice = sublimation - solid precipitation as liquid
1077	!! precipitation are re-routed directly to the ocean and
1078	!! runoffs and calving directly enter the ocean.
1079	!! * solid precipitation (sprecip), used to add to qns_tot
1080	!! the heat lost associated to melting solid precipitation
1081	!! over the ocean fraction.
1082	!! ===>> CAUTION here this changes the net heat flux received from
1083	!! the atmosphere
1084	!!
1085	!! - the fluxes have been separated from the stress as
1086	!! (a) they are updated at each ice time step compare to
1087	!! an update at each coupled time step for the stress, and
1088	!! (b) the conservative computation of the fluxes over the
1089	!! sea-ice area requires the knowledge of the ice fraction
1090	!! after the ice advection and before the ice thermodynamics,
1091	!! so that the stress is updated before the ice dynamics
1092	!! while the fluxes are updated after it.
1093	!!
1094	!! ** Action : update at each nf_ice time step:
1095	!! qns_tot, qsr_tot non-solar and solar total heat fluxes
1096	!! qns_ice, qsr_ice non-solar and solar heat fluxes over the ice
1097	!! emp_tot total evaporation - precipitation(liquid and solid) (-runoff)(-calving)
1098	!! emp_ice ice sublimation - solid precipitation over the ice
1099	!! dqns_ice d(non-solar heat flux)/d(Temperature) over the ice
1100	!! sprecip solid precipitation over the ocean
1101	!!----------------------------------------------------------------------
1102	REAL(wp), INTENT(in ), DIMENSION(:,:) :: p_frld ! lead fraction [0 to 1]
1103	! optional arguments, used only in 'mixed oce-ice' case
1104	REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo
1105	REAL(wp), INTENT(in ), DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius]
1106	REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin]
1107	!
1108	INTEGER :: jl ! dummy loop index
1109	REAL(wp), POINTER, DIMENSION(:,:) :: zcptn, ztmp, zicefr
1110	!!----------------------------------------------------------------------
1111	!
1112	IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_ice_flx')
1113	!
1114	CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr )
1115
1116	zicefr(:,:) = 1.- p_frld(:,:)
1117	zcptn(:,:) = rcp * sst_m(:,:)
1118	!
1119	! ! ========================= !
1120	! ! freshwater budget ! (emp)
1121	! ! ========================= !
1122	!
1123	! ! total Precipitations - total Evaporation (emp_tot)
1124	! ! solid precipitation - sublimation (emp_ice)
1125	! ! solid Precipitation (sprecip)
1126	SELECT CASE( TRIM( sn_rcv_emp%cldes ) )
1127	CASE( 'conservative' ) ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp
1128	sprecip(:,:) = frcv(jpr_snow)%z3(:,:,1) ! May need to ensure positive here
1129	tprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + sprecip (:,:) ! May need to ensure positive here
1130	emp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - tprecip(:,:)
1131	emp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1)
1132	CALL iom_put( 'rain' , frcv(jpr_rain)%z3(:,:,1) ) ! liquid precipitation
1133	IF( iom_use('hflx_rain_cea') ) &
1134	CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from liq. precip.
1135	IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) &
1136	ztmp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:)
1137	IF( iom_use('evap_ao_cea' ) ) &
1138	CALL iom_put( 'evap_ao_cea' , ztmp ) ! ice-free oce evap (cell average)
1139	IF( iom_use('hflx_evap_cea') ) &
1140	CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) ) ! heat flux from from evap (cell average)
1141	CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp
1142	emp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1)
1143	emp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1)
1144	sprecip(:,:) = - frcv(jpr_semp)%z3(:,:,1) + frcv(jpr_ievp)%z3(:,:,1)
1145	END SELECT
1146
1147	CALL iom_put( 'snowpre' , sprecip ) ! Snow
1148	IF( iom_use('snow_ao_cea') ) &
1149	CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:) ) ! Snow over ice-free ocean (cell average)
1150	IF( iom_use('snow_ai_cea') ) &
1151	CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) ) ! Snow over sea-ice (cell average)
1152	IF( iom_use('subl_ai_cea') ) &
1153	CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) ! Sublimation over sea-ice (cell average)
1154	!
1155	! ! runoffs and calving (put in emp_tot)
1156	IF( srcv(jpr_rnf)%laction ) THEN
1157	emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_rnf)%z3(:,:,1)
1158	CALL iom_put( 'runoffs' , frcv(jpr_rnf)%z3(:,:,1) ) ! rivers
1159	IF( iom_use('hflx_rnf_cea') ) &
1160	CALL iom_put( 'hflx_rnf_cea' , frcv(jpr_rnf)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from rivers
1161	ENDIF
1162	IF( srcv(jpr_cal)%laction ) THEN
1163	emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1)
1164	CALL iom_put( 'calving', frcv(jpr_cal)%z3(:,:,1) )
1165	ENDIF
1166	!
1167	!!gm : this seems to be internal cooking, not sure to need that in a generic interface
1168	!!gm at least should be optional...
1169	!! ! remove negative runoff ! sum over the global domain
1170	!! zcumulpos = SUM( MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )
1171	!! zcumulneg = SUM( MIN( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )
1172	!! IF( lk_mpp ) CALL mpp_sum( zcumulpos )
1173	!! IF( lk_mpp ) CALL mpp_sum( zcumulneg )
1174	!! IF( zcumulpos /= 0. ) THEN ! distribute negative runoff on positive runoff grid points
1175	!! zcumulneg = 1.e0 + zcumulneg / zcumulpos
1176	!! frcv(jpr_rnf)%z3(:,:,1) = MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * zcumulneg
1177	!! ENDIF
1178	!! emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_rnf)%z3(:,:,1) ! add runoff to e-p
1179	!!
1180	!!gm end of internal cooking
1181
1182	! ! ========================= !
1183	SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) ! non solar heat fluxes ! (qns)
1184	! ! ========================= !
1185	CASE( 'oce only' ) ! the required field is directly provided
1186	qns_tot(:,: ) = frcv(jpr_qnsoce)%z3(:,:,1)
1187	CASE( 'conservative' ) ! the required fields are directly provided
1188	qns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1)
1189	IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN
1190	qns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl)
1191	ELSE
1192	! Set all category values equal for the moment
1193	DO jl=1,jpl
1194	qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1)
1195	ENDDO
1196	ENDIF
1197	CASE( 'oce and ice' ) ! the total flux is computed from ocean and ice fluxes
1198	qns_tot(:,: ) = p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1)
1199	IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN
1200	DO jl=1,jpl
1201	qns_tot(:,: ) = qns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl)
1202	qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl)
1203	ENDDO
1204	ELSE
1205	DO jl=1,jpl
1206	qns_tot(:,: ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1)
1207	qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1)
1208	ENDDO
1209	ENDIF
1210	CASE( 'mixed oce-ice' ) ! the ice flux is cumputed from the total flux, the SST and ice informations
1211	! NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED
1212	qns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1)
1213	qns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1) &
1214	& + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,: ) ) * p_frld(:,:) &
1215	& + pist(:,:,1) * zicefr(:,:) ) )
1216	END SELECT
1217	ztmp(:,:) = p_frld(:,:) * sprecip(:,:) * lfus
1218	qns_tot(:,:) = qns_tot(:,:) & ! qns_tot update over free ocean with:
1219	& - ztmp(:,:) & ! remove the latent heat flux of solid precip. melting
1220	& - ( emp_tot(:,:) & ! remove the heat content of mass flux (assumed to be at SST)
1221	& - emp_ice(:,:) * zicefr(:,:) ) * zcptn(:,:)
1222	IF( iom_use('hflx_snow_cea') ) &
1223	CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) ) ! heat flux from snow (cell average)
1224	!!gm
1225	!! currently it is taken into account in leads budget but not in the qns_tot, and thus not in
1226	!! the flux that enter the ocean....
1227	!! moreover 1 - it is not diagnose anywhere....
1228	!! 2 - it is unclear for me whether this heat lost is taken into account in the atmosphere or not...
1229	!!
1230	!! similar job should be done for snow and precipitation temperature
1231	!
1232	IF( srcv(jpr_cal)%laction ) THEN ! Iceberg melting
1233	ztmp(:,:) = frcv(jpr_cal)%z3(:,:,1) * lfus ! add the latent heat of iceberg melting
1234	qns_tot(:,:) = qns_tot(:,:) - ztmp(:,:)
1235	IF( iom_use('hflx_cal_cea') ) &
1236	CALL iom_put( 'hflx_cal_cea', ztmp + frcv(jpr_cal)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from calving
1237	ENDIF
1238
1239	! ! ========================= !
1240	SELECT CASE( TRIM( sn_rcv_qsr%cldes ) ) ! solar heat fluxes ! (qsr)
1241	! ! ========================= !
1242	CASE( 'oce only' )
1243	qsr_tot(:,: ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) )
1244	CASE( 'conservative' )
1245	qsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1)
1246	IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN
1247	qsr_ice(:,:,1:jpl) = frcv(jpr_qsrice)%z3(:,:,1:jpl)
1248	ELSE
1249	! Set all category values equal for the moment
1250	DO jl=1,jpl
1251	qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1)
1252	ENDDO
1253	ENDIF
1254	qsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1)
1255	qsr_ice(:,:,1) = frcv(jpr_qsrice)%z3(:,:,1)
1256	CASE( 'oce and ice' )
1257	qsr_tot(:,: ) = p_frld(:,:) * frcv(jpr_qsroce)%z3(:,:,1)
1258	IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN
1259	DO jl=1,jpl
1260	qsr_tot(:,: ) = qsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl)
1261	qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl)
1262	ENDDO
1263	ELSE
1264	DO jl=1,jpl
1265	qsr_tot(:,: ) = qsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1)
1266	qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1)
1267	ENDDO
1268	ENDIF
1269	CASE( 'mixed oce-ice' )
1270	qsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1)
1271	! NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED
1272	! Create solar heat flux over ice using incoming solar heat flux and albedos
1273	! ( see OASIS3 user guide, 5th edition, p39 )
1274	qsr_ice(:,:,1) = frcv(jpr_qsrmix)%z3(:,:,1) * ( 1.- palbi(:,:,1) ) &
1275	& / ( 1.- ( albedo_oce_mix(:,: ) * p_frld(:,:) &
1276	& + palbi (:,:,1) * zicefr(:,:) ) )
1277	END SELECT
1278	IF( ln_dm2dc ) THEN ! modify qsr to include the diurnal cycle
1279	qsr_tot(:,: ) = sbc_dcy( qsr_tot(:,: ) )
1280	DO jl=1,jpl
1281	qsr_ice(:,:,jl) = sbc_dcy( qsr_ice(:,:,jl) )
1282	ENDDO
1283	ENDIF
1284
1285	! ! ========================= !
1286	SELECT CASE( TRIM( sn_rcv_dqnsdt%cldes ) ) ! d(qns)/dt !
1287	! ! ========================= !
1288	CASE ('coupled')
1289	IF ( TRIM(sn_rcv_dqnsdt%clcat) == 'yes' ) THEN
1290	dqns_ice(:,:,1:jpl) = frcv(jpr_dqnsdt)%z3(:,:,1:jpl)
1291	ELSE
1292	! Set all category values equal for the moment
1293	DO jl=1,jpl
1294	dqns_ice(:,:,jl) = frcv(jpr_dqnsdt)%z3(:,:,1)
1295	ENDDO
1296	ENDIF
1297	END SELECT
1298
1299	! ! ========================= !
1300	SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) ) ! topmelt and botmelt !
1301	! ! ========================= !
1302	CASE ('coupled')
1303	topmelt(:,:,:)=frcv(jpr_topm)%z3(:,:,:)
1304	botmelt(:,:,:)=frcv(jpr_botm)%z3(:,:,:)
1305	END SELECT
1306
1307	! Surface transimission parameter io (Maykut Untersteiner , 1971 ; Ebert and Curry, 1993 )
1308	! Used for LIM2 and LIM3
1309	! Coupled case: since cloud cover is not received from atmosphere
1310	! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81)
1311	fr1_i0(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice )
1312	fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice )
1313
1314	CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr )
1315	!
1316	IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_ice_flx')
1317	!
1318	END SUBROUTINE sbc_cpl_ice_flx
1319
1320
1321	SUBROUTINE sbc_cpl_snd( kt )
1322	!!----------------------------------------------------------------------
1323	!! * ROUTINE sbc_cpl_snd *
1324	!!
1325	!! ** Purpose : provide the ocean-ice informations to the atmosphere
1326	!!
1327	!! ** Method : send to the atmosphere through a call to cpl_snd
1328	!! all the needed fields (as defined in sbc_cpl_init)
1329	!!----------------------------------------------------------------------
1330	INTEGER, INTENT(in) :: kt
1331	!
1332	INTEGER :: ji, jj, jl ! dummy loop indices
1333	INTEGER :: isec, info ! local integer
1334	REAL(wp), POINTER, DIMENSION(:,:) :: zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1
1335	REAL(wp), POINTER, DIMENSION(:,:,:) :: ztmp3, ztmp4
1336	!!----------------------------------------------------------------------
1337	!
1338	IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_snd')
1339	!
1340	CALL wrk_alloc( jpi,jpj, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 )
1341	CALL wrk_alloc( jpi,jpj,jpl, ztmp3, ztmp4 )
1342
1343	isec = ( kt - nit000 ) * NINT(rdttra(1)) ! date of exchanges
1344
1345	zfr_l(:,:) = 1.- fr_i(:,:)
1346	! ! ------------------------- !
1347	! ! Surface temperature ! in Kelvin
1348	! ! ------------------------- !
1349	IF( ssnd(jps_toce)%laction .OR. ssnd(jps_tice)%laction .OR. ssnd(jps_tmix)%laction ) THEN
1350	SELECT CASE( sn_snd_temp%cldes)
1351	CASE( 'oce only' ) ; ztmp1(:,:) = tsn(:,:,1,jp_tem) + rt0
1352	CASE( 'weighted oce and ice' ) ; ztmp1(:,:) = ( tsn(:,:,1,jp_tem) + rt0 ) * zfr_l(:,:)
1353	SELECT CASE( sn_snd_temp%clcat )
1354	CASE( 'yes' )
1355	ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl)
1356	CASE( 'no' )
1357	ztmp3(:,:,:) = 0.0
1358	DO jl=1,jpl
1359	ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl)
1360	ENDDO
1361	CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' )
1362	END SELECT
1363	CASE( 'mixed oce-ice' )
1364	ztmp1(:,:) = ( tsn(:,:,1,jp_tem) + rt0 ) * zfr_l(:,:)
1365	DO jl=1,jpl
1366	ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl)
1367	ENDDO
1368	CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' )
1369	END SELECT
1370	IF( ssnd(jps_toce)%laction ) CALL cpl_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
1371	IF( ssnd(jps_tice)%laction ) CALL cpl_snd( jps_tice, isec, ztmp3, info )
1372	IF( ssnd(jps_tmix)%laction ) CALL cpl_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
1373	ENDIF
1374	! ! ------------------------- !
1375	! ! Albedo !
1376	! ! ------------------------- !
1377	IF( ssnd(jps_albice)%laction ) THEN ! ice
1378	ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl)
1379	CALL cpl_snd( jps_albice, isec, ztmp3, info )
1380	ENDIF
1381	IF( ssnd(jps_albmix)%laction ) THEN ! mixed ice-ocean
1382	ztmp1(:,:) = albedo_oce_mix(:,:) * zfr_l(:,:)
1383	DO jl=1,jpl
1384	ztmp1(:,:) = ztmp1(:,:) + alb_ice(:,:,jl) * a_i(:,:,jl)
1385	ENDDO
1386	CALL cpl_snd( jps_albmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
1387	ENDIF
1388	! ! ------------------------- !
1389	! ! Ice fraction & Thickness !
1390	! ! ------------------------- !
1391	! Send ice fraction field
1392	IF( ssnd(jps_fice)%laction ) THEN
1393	SELECT CASE( sn_snd_thick%clcat )
1394	CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(:,:,1:jpl)
1395	CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(:,: )
1396	CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' )
1397	END SELECT
1398	CALL cpl_snd( jps_fice, isec, ztmp3, info )
1399	ENDIF
1400
1401	! Send ice and snow thickness field
1402	IF( ssnd(jps_hice)%laction .OR. ssnd(jps_hsnw)%laction ) THEN
1403	SELECT CASE( sn_snd_thick%cldes)
1404	CASE( 'none' ) ! nothing to do
1405	CASE( 'weighted ice and snow' )
1406	SELECT CASE( sn_snd_thick%clcat )
1407	CASE( 'yes' )
1408	ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl) * a_i(:,:,1:jpl)
1409	ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl) * a_i(:,:,1:jpl)
1410	CASE( 'no' )
1411	ztmp3(:,:,:) = 0.0 ; ztmp4(:,:,:) = 0.0
1412	DO jl=1,jpl
1413	ztmp3(:,:,1) = ztmp3(:,:,1) + ht_i(:,:,jl) * a_i(:,:,jl)
1414	ztmp4(:,:,1) = ztmp4(:,:,1) + ht_s(:,:,jl) * a_i(:,:,jl)
1415	ENDDO
1416	CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' )
1417	END SELECT
1418	CASE( 'ice and snow' )
1419	ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl)
1420	ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl)
1421	CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%cldes' )
1422	END SELECT
1423	IF( ssnd(jps_hice)%laction ) CALL cpl_snd( jps_hice, isec, ztmp3, info )
1424	IF( ssnd(jps_hsnw)%laction ) CALL cpl_snd( jps_hsnw, isec, ztmp4, info )
1425	ENDIF
1426	!
1427	#if defined key_cpl_carbon_cycle
1428	! ! ------------------------- !
1429	! ! CO2 flux from PISCES !
1430	! ! ------------------------- !
1431	IF( ssnd(jps_co2)%laction ) CALL cpl_snd( jps_co2, isec, RESHAPE ( oce_co2, (/jpi,jpj,1/) ) , info )
1432	!
1433	#endif
1434	! ! ------------------------- !
1435	IF( ssnd(jps_ocx1)%laction ) THEN ! Surface current !
1436	! ! ------------------------- !
1437	!
1438	! j+1 j -----V---F
1439	! surface velocity always sent from T point ! \|
1440	! j \| T U
1441	! \| \|
1442	! j j-1 -I-------\|
1443	! (for I) \| \|
1444	! i-1 i i
1445	! i i+1 (for I)
1446	SELECT CASE( TRIM( sn_snd_crt%cldes ) )
1447	CASE( 'oce only' ) ! C-grid ==> T
1448	DO jj = 2, jpjm1
1449	DO ji = fs_2, fs_jpim1 ! vector opt.
1450	zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) )
1451	zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) )
1452	END DO
1453	END DO
1454	CASE( 'weighted oce and ice' )
1455	SELECT CASE ( cp_ice_msh )
1456	CASE( 'C' ) ! Ocean and Ice on C-grid ==> T
1457	DO jj = 2, jpjm1
1458	DO ji = fs_2, fs_jpim1 ! vector opt.
1459	zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj)
1460	zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * zfr_l(ji,jj)
1461	zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj)
1462	zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj)
1463	END DO
1464	END DO
1465	CASE( 'I' ) ! Ocean on C grid, Ice on I-point (B-grid) ==> T
1466	DO jj = 2, jpjm1
1467	DO ji = 2, jpim1 ! NO vector opt.
1468	zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj)
1469	zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj)
1470	zitx1(ji,jj) = 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1) &
1471	& + u_ice(ji+1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj)
1472	zity1(ji,jj) = 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1) &
1473	& + v_ice(ji+1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj)
1474	END DO
1475	END DO
1476	CASE( 'F' ) ! Ocean on C grid, Ice on F-point (B-grid) ==> T
1477	DO jj = 2, jpjm1
1478	DO ji = 2, jpim1 ! NO vector opt.
1479	zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj)
1480	zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj)
1481	zitx1(ji,jj) = 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1) &
1482	& + u_ice(ji-1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj)
1483	zity1(ji,jj) = 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1) &
1484	& + v_ice(ji-1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj)
1485	END DO
1486	END DO
1487	END SELECT
1488	CALL lbc_lnk( zitx1, 'T', -1. ) ; CALL lbc_lnk( zity1, 'T', -1. )
1489	CASE( 'mixed oce-ice' )
1490	SELECT CASE ( cp_ice_msh )
1491	CASE( 'C' ) ! Ocean and Ice on C-grid ==> T
1492	DO jj = 2, jpjm1
1493	DO ji = fs_2, fs_jpim1 ! vector opt.
1494	zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) &
1495	& + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj)
1496	zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * zfr_l(ji,jj) &
1497	& + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj)
1498	END DO
1499	END DO
1500	CASE( 'I' ) ! Ocean on C grid, Ice on I-point (B-grid) ==> T
1501	DO jj = 2, jpjm1
1502	DO ji = 2, jpim1 ! NO vector opt.
1503	zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj) &
1504	& + 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1) &
1505	& + u_ice(ji+1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj)
1506	zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj) &
1507	& + 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1) &
1508	& + v_ice(ji+1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj)
1509	END DO
1510	END DO
1511	CASE( 'F' ) ! Ocean on C grid, Ice on F-point (B-grid) ==> T
1512	DO jj = 2, jpjm1
1513	DO ji = 2, jpim1 ! NO vector opt.
1514	zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj) &
1515	& + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1) &
1516	& + u_ice(ji-1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj)
1517	zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj) &
1518	& + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1) &
1519	& + v_ice(ji-1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj)
1520	END DO
1521	END DO
1522	END SELECT
1523	END SELECT
1524	CALL lbc_lnk( zotx1, ssnd(jps_ocx1)%clgrid, -1. ) ; CALL lbc_lnk( zoty1, ssnd(jps_ocy1)%clgrid, -1. )
1525	!
1526	!
1527	IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components
1528	! ! Ocean component
1529	CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component
1530	CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component
1531	zotx1(:,:) = ztmp1(:,:) ! overwrite the components
1532	zoty1(:,:) = ztmp2(:,:)
1533	IF( ssnd(jps_ivx1)%laction ) THEN ! Ice component
1534	CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component
1535	CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component
1536	zitx1(:,:) = ztmp1(:,:) ! overwrite the components
1537	zity1(:,:) = ztmp2(:,:)
1538	ENDIF
1539	ENDIF
1540	!
1541	! spherical coordinates to cartesian -> 2 components to 3 components
1542	IF( TRIM( sn_snd_crt%clvref ) == 'cartesian' ) THEN
1543	ztmp1(:,:) = zotx1(:,:) ! ocean currents
1544	ztmp2(:,:) = zoty1(:,:)
1545	CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 )
1546	!
1547	IF( ssnd(jps_ivx1)%laction ) THEN ! ice velocities
1548	ztmp1(:,:) = zitx1(:,:)
1549	ztmp1(:,:) = zity1(:,:)
1550	CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 )
1551	ENDIF
1552	ENDIF
1553	!
1554	IF( ssnd(jps_ocx1)%laction ) CALL cpl_snd( jps_ocx1, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid
1555	IF( ssnd(jps_ocy1)%laction ) CALL cpl_snd( jps_ocy1, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid
1556	IF( ssnd(jps_ocz1)%laction ) CALL cpl_snd( jps_ocz1, isec, RESHAPE ( zotz1, (/jpi,jpj,1/) ), info ) ! ocean z current 1st grid
1557	!
1558	IF( ssnd(jps_ivx1)%laction ) CALL cpl_snd( jps_ivx1, isec, RESHAPE ( zitx1, (/jpi,jpj,1/) ), info ) ! ice x current 1st grid
1559	IF( ssnd(jps_ivy1)%laction ) CALL cpl_snd( jps_ivy1, isec, RESHAPE ( zity1, (/jpi,jpj,1/) ), info ) ! ice y current 1st grid
1560	IF( ssnd(jps_ivz1)%laction ) CALL cpl_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/jpi,jpj,1/) ), info ) ! ice z current 1st grid
1561	!
1562	ENDIF
1563	!
1564	CALL wrk_dealloc( jpi,jpj, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 )
1565	CALL wrk_dealloc( jpi,jpj,jpl, ztmp3, ztmp4 )
1566	!
1567	IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_snd')
1568	!
1569	END SUBROUTINE sbc_cpl_snd
1570
1571	!!======================================================================
1572	END MODULE sbccpl

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

Download in other formats: