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

Context Navigation

source: branches/dev_003_CPL/NEMO/OPA_SRC/SBC/sbccpl.F90 @ 1211

Last change on this file since 1211 was 1211, checked in by smasson, 16 years ago
minor bugfix for cpl module under construction... see ticket:155
File size: 48.2 KB

Line
1	MODULE sbccpl
2	!!======================================================================
3	!! * MODULE sbccpl *
4	!! Ocean forcing: momentum, heat and freshwater coupled formulation
5	!!=====================================================================
6	!! History : 9.0 ! 06-07 (R. Redler, N. Keenlyside, W. Park)
7	!! Original code split into flxmod & taumod
8	!! 9.0 ! 06-07 (G. Madec) surface module
9	!!----------------------------------------------------------------------
10	#if defined key_oasis3 \|\| defined key_oasis4
11	!!----------------------------------------------------------------------
12	!! 'key_oasis3' or 'key_oasis4' Coupled Ocean/Atmosphere formulation
13	!!----------------------------------------------------------------------
14	!!----------------------------------------------------------------------
15	!! namsbc_cpl : coupled formulation namlist
16	!! sbc_cpl : coupled formulation for the ocean surface boundary condition
17	!!----------------------------------------------------------------------
18
19	USE dom_oce ! ocean space and time domain
20	USE sbc_oce ! Surface boundary condition: ocean fields
21	USE sbc_ice ! Surface boundary condition: ice fields
22	#if defined key_lim3
23	USE par_ice ! ice parameters
24	#endif
25	USE cpl_oasis3 ! OASIS3 coupling (to ECHAM5)
26	USE geo2ocean
27	USE restart
28	USE in_out_manager ! I/O manager
29	USE iom ! NetCDF library
30	USE lib_mpp ! distribued memory computing library
31	USE lbclnk ! ocean lateral boundary conditions (or mpp link)
32	USE oce, ONLY : tn, un, vn
33	USE phycst, ONLY : rt0
34	USE albedo
35
36	IMPLICIT NONE
37
38	# include "vectopt_loop_substitute.h90"
39	PRIVATE
40
41	PUBLIC sbc_cpl_snd ! routine called by step.F90
42	PUBLIC sbc_cpl_rcv ! routine called by step.F90
43
44	INTEGER :: jprcv_qsroce, jprcv_qsrice, jprcv_qsrmix ! Index used for qsr
45	INTEGER :: jprcv_qnsoce, jprcv_qnsice, jprcv_qnsmix ! Index used for qns
46	INTEGER :: jprcv_rain, jprcv_snow, jprcv_tevp, jprcv_ievp, jprcv_tpre, jprcv_spre, jprcv_oemp ! Index used for water flux
47	INTEGER :: jprcv_otx1, jprcv_oty1, jprcv_otz1, jprcv_otx2, jprcv_oty2, jprcv_otz2 ! Index used for wind stress on oce
48	INTEGER :: jprcv_itx1, jprcv_ity1, jprcv_itz1, jprcv_itx2, jprcv_ity2, jprcv_itz2 ! Index used for wind stress on ice
49	INTEGER :: jprcv_w10m ! Index used for 10m wind
50	INTEGER :: jprcv_dqnsdt ! Index used for dqnsdt
51	INTEGER :: jprcv_rnf ! Index used for runoff
52	INTEGER :: jprcv_cal ! Index used for calving
53
54	INTEGER :: jpsnd_fice ! Index used for ice fraction
55	INTEGER :: jpsnd_toce, jpsnd_tice, jpsnd_tmix ! Index used for temperature
56	INTEGER :: jpsnd_albice, jpsnd_albmix ! Index used for albedo
57	INTEGER :: jpsnd_tckice, jpsnd_tcksnw ! Index used for thickness
58	INTEGER :: jpsnd_ocx1, jpsnd_ocy1, jpsnd_ocz1, jpsnd_ocx2, jpsnd_ocy2, jpsnd_ocz2 ! Index used for current velocity
59	INTEGER :: jpsnd_ivx1, jpsnd_ivy1, jpsnd_ivz1, jpsnd_ivx2, jpsnd_ivy2, jpsnd_ivz2 ! Index used for ice velocity
60	INTEGER, DIMENSION(jpi,jpj) :: mskneg, mskpos
61	! Masks uses for negative runoff suppression
62
63	CHARACTER(len=100) :: cn_snd_temperature, cn_snd_albedo, cn_snd_thickness, & ! Description of coupled mode
64	cn_snd_current_1, cn_snd_current_2, cn_snd_current_3, cn_snd_current_4, &
65	cn_rcv_w10m, cn_rcv_stress_1, cn_rcv_stress_2, cn_rcv_stress_3, &
66	cn_rcv_stress_4,cn_rcv_dqnsdt, cn_rcv_qsr, cn_rcv_qns, cn_rcv_emp, &
67	cn_rcv_cal
68
69	CHARACTER(len=100), PUBLIC :: cn_rcv_rnf
70
71	CHARACTER(len=100), DIMENSION(4) :: cn_snd_current, cn_rcv_stress
72
73	REAL(wp) :: zcumulneg, zcumulpos
74	! Temporary buffer for runoff averages
75	REAL(wp), DIMENSION(jpi,jpj) :: cpl_ocean_albedo, albedo_oce_cs, albedo_oce_ov ! Values for ocean albedo sent to atmosphere
76
77	!!----------------------------------------------------------------------
78	!! OPA 9.0 , LOCEAN-IPSL (2006)
79	!! $ Id: $
80	!! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
81	!!----------------------------------------------------------------------
82
83	CONTAINS
84
85	SUBROUTINE sbc_cpl_init
86
87	!!! >> Arnaud pour lire freeze, alb_ice et tn_ice dans le restart oasis
88	USE netcdf
89
90	INTEGER :: ncid, varid,ierr
91	!!! << Arnaud
92
93	CHARACTER(len=1), DIMENSION(100) :: cltmp
94	INTEGER :: i
95
96	NAMELIST/namsbc_cpl/ cn_snd_temperature, cn_snd_albedo, cn_snd_thickness, &
97	cn_snd_current_1, cn_snd_current_2, cn_snd_current_3, cn_snd_current_4, &
98	cn_rcv_w10m, cn_rcv_stress_1, cn_rcv_stress_2, cn_rcv_stress_3, &
99	cn_rcv_stress_4, cn_rcv_dqnsdt, cn_rcv_qsr, cn_rcv_qns, cn_rcv_emp, &
100	cn_rcv_rnf, cn_rcv_cal
101
102
103	!!---------------------------------------------------------------------
104
105
106	REWIND( numnam ) ! ... read in namlist namsbc_cpl_rcv
107	READ ( numnam, namsbc_cpl )
108
109	cn_snd_current(1)=cn_snd_current_1 ; cn_snd_current(2)=cn_snd_current_2
110	cn_snd_current(3)=cn_snd_current_3 ; cn_snd_current(4)=cn_snd_current_4
111	cn_rcv_stress(1)=cn_rcv_stress_1 ; cn_rcv_stress(2)=cn_rcv_stress_2
112	cn_rcv_stress(3)=cn_rcv_stress_3 ; cn_rcv_stress(4)=cn_rcv_stress_4
113
114	!-------------------------------------
115	!-------------------------------------
116	! Define the receive interface
117	!-------------------------------------
118	!-------------------------------------
119	!
120	! Read restart of variables for coupling (needed to compute some values from the received data)
121
122
123	!!$ Probleme: definir comment on initialise freeze, alb_ice et tn_ice
124	!!$ quand on n'a pas de restart (a nit000)
125	!! >> Eric: pour le premier pas de temps du premier jour de la simulation
126	!! >> je prefere faire un truc vraiment crade
127	!! >> vu que c est vraiment la premiere et derniere occasion
128
129	!!! >> Arnaud pour lire freeze, alb_ice et tn_ice dans le restart oasis
130
131	! CALL iom_get( numror, jpdom_local_full, 'freeze' , freeze )
132
133	!!! ierr = nf90_OPEN('sstoc.nc',NF90_NOWRITE,ncid)
134
135	!!! ierr = NF90_INQ_VARID(ncid,'OIceFrac',varid)
136	!!! ierr = NF90_GET_VAR(ncid,varid,freeze)
137
138	!!! ierr = NF90_INQ_VARID(ncid,'O_AlbIce',varid)
139	!!! ierr = NF90_GET_VAR(ncid,varid,alb_ice)
140
141	!!! ierr = NF90_INQ_VARID(ncid,'O_TepIce',varid)
142	!!! ierr = NF90_GET_VAR(ncid,varid,tn_ice)
143
144	!!! ierr = NF90_close(ncid)
145
146	!!! << Arnaud
147
148	!!!!!
149	!!!!! +++ ERIC tu utilises tn_ice dans le calcule de Qns, c'est bien ca???
150	!!!!!
151	! Eric : oui mais cette valeur est deja sauvee dans le restart glace
152	! c est donc peut etre inutile de la sauver aussi dans le restart ocean
153	!
154	! IF ( TRIM(cn_rcv_qsr) == 'mixed oce-ice' ) CALL iom_get( numror, jpdom_local_full, 'alb_ice', alb_ice )
155	! IF ( TRIM(cn_rcv_qns) == 'mixed oce-ice' ) CALL iom_get( numror, jpdom_local_full, 'tn_ice' , tn_ice )
156
157	! default definitions of srcv
158	nrcv = 0
159	srcv(:)%laction = .FALSE.
160	srcv(:)%clgrid = 'T'
161	srcv(:)%nsgn = 1
162
163	!-------------------------------------
164	! Qsr
165	nrcv = nrcv + 1 ; jprcv_qsroce = nrcv ; srcv(nrcv)%clname = 'O_QsrOce'
166	nrcv = nrcv + 1 ; jprcv_qsrice = nrcv ; srcv(nrcv)%clname = 'O_QsrIce'
167	nrcv = nrcv + 1 ; jprcv_qsrmix = nrcv ; srcv(nrcv)%clname = 'O_QsrMix'
168	SELECT CASE (TRIM(cn_rcv_qsr))
169	CASE( 'conservative' ) ; srcv( (/jprcv_qsrice, jprcv_qsrmix/) )%laction = .TRUE.
170	CASE( 'oce and ice' ) ; srcv( (/jprcv_qsrice, jprcv_qsroce/) )%laction = .TRUE.
171	CASE( 'mixed oce-ice' ) ; srcv( jprcv_qsrmix )%laction = .TRUE.
172	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_rcv_qsr' )
173	END SELECT
174
175	!-------------------------------------
176	! Qns
177	nrcv = nrcv + 1 ; jprcv_qnsoce = nrcv ; srcv(nrcv)%clname = 'O_QnsOce'
178	nrcv = nrcv + 1 ; jprcv_qnsice = nrcv ; srcv(nrcv)%clname = 'O_QnsIce'
179	nrcv = nrcv + 1 ; jprcv_qnsmix = nrcv ; srcv(nrcv)%clname = 'O_QnsMix'
180	SELECT CASE (TRIM(cn_rcv_qns))
181	CASE( 'conservative' ) ; srcv( (/jprcv_qnsice, jprcv_qnsmix/) )%laction = .TRUE.
182	CASE( 'oce and ice' ) ; srcv( (/jprcv_qnsice, jprcv_qnsoce/) )%laction = .TRUE.
183	CASE( 'mixed oce-ice' ) ; srcv( jprcv_qnsmix )%laction = .TRUE.
184	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_rcv_qns' )
185	END SELECT
186
187	!-------------------------------------
188	! emp, tprecip and sprecip
189	nrcv = nrcv + 1 ; jprcv_rain = nrcv ; srcv(nrcv)%clname = 'OIceRain' ! Rain = liquid precipitation
190	nrcv = nrcv + 1 ; jprcv_snow = nrcv ; srcv(nrcv)%clname = 'OIceSnow'
191	nrcv = nrcv + 1 ; jprcv_tevp = nrcv ; srcv(nrcv)%clname = 'OTotEvap' ! total evaporation ( over oce + ice )
192	nrcv = nrcv + 1 ; jprcv_ievp = nrcv ; srcv(nrcv)%clname = 'OIceEvap' ! evaporation iver ice (sublimation)
193	nrcv = nrcv + 1 ; jprcv_tpre = nrcv ; srcv(nrcv)%clname = 'OIPr-Sub' ! Pr = liquid + solid precipitation
194	nrcv = nrcv + 1 ; jprcv_spre = nrcv ; srcv(nrcv)%clname = 'OISn-Sub' ! Sub = Sublimation = Evap over ice
195	nrcv = nrcv + 1 ; jprcv_oemp = nrcv ; srcv(nrcv)%clname = 'OOEv-OPr' !
196	SELECT CASE (TRIM(cn_rcv_emp))
197	CASE( 'conservative' ) ; srcv( (/jprcv_rain, jprcv_snow, jprcv_ievp, jprcv_tevp/) )%laction = .TRUE.
198	CASE( 'oce and ice' ) ; srcv( (/ jprcv_tpre, jprcv_spre, jprcv_oemp/) )%laction = .TRUE.
199	CASE( 'mixed oce-ice' ) ; srcv( (/jprcv_rain, jprcv_snow, jprcv_tevp/) )%laction = .TRUE.
200	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_rcv_emp' )
201	END SELECT
202
203
204	!-------------------------------------
205	! wind stress : utau, vtau, utaui_ice, vtaui_ice
206	! oce stress
207	nrcv = nrcv + 1 ; jprcv_otx1 = nrcv ; srcv(nrcv)%clname = 'O_OTaux1' ! oce tau 1st component on 1st grid
208	nrcv = nrcv + 1 ; jprcv_oty1 = nrcv ; srcv(nrcv)%clname = 'O_OTauy1' ! oce tau 2nd component on 1st grid
209	nrcv = nrcv + 1 ; jprcv_otz1 = nrcv ; srcv(nrcv)%clname = 'O_OTauz1' ! oce tau 3rd component on 1st grid
210	nrcv = nrcv + 1 ; jprcv_otx2 = nrcv ; srcv(nrcv)%clname = 'O_OTaux2' ! oce tau 1st component on 2nd grid
211	nrcv = nrcv + 1 ; jprcv_oty2 = nrcv ; srcv(nrcv)%clname = 'O_OTauy2' ! oce tau 2nd component on 2nd grid
212	nrcv = nrcv + 1 ; jprcv_otz2 = nrcv ; srcv(nrcv)%clname = 'O_OTauz2' ! oce tau 3rd component on 2nd grid
213	! ice stress
214	nrcv = nrcv + 1 ; jprcv_itx1 = nrcv ; srcv(nrcv)%clname = 'O_ITaux1' ! ice tau 1st component on 1st grid
215	nrcv = nrcv + 1 ; jprcv_ity1 = nrcv ; srcv(nrcv)%clname = 'O_ITauy1' ! ice tau 2nd component on 1st grid
216	nrcv = nrcv + 1 ; jprcv_itz1 = nrcv ; srcv(nrcv)%clname = 'O_ITauz1' ! ice tau 3rd component on 1st grid
217	nrcv = nrcv + 1 ; jprcv_itx2 = nrcv ; srcv(nrcv)%clname = 'O_ITaux2' ! ice tau 1st component on 2nd grid
218	nrcv = nrcv + 1 ; jprcv_ity2 = nrcv ; srcv(nrcv)%clname = 'O_ITauy2' ! ice tau 2nd component on 2nd grid
219	nrcv = nrcv + 1 ; jprcv_itz2 = nrcv ; srcv(nrcv)%clname = 'O_ITauz2' ! ice tau 3rd component on 2nd grid
220	! change default definition of srcv(:)%nsgn
221	srcv(jprcv_otx1:jprcv_itz2)%nsgn = -1
222	! change default definition of srcv(:)%clgrid and srcv(:)%laction
223
224	DO i=1,5
225	cltmp(i)= cn_rcv_stress_4(i:i)
226	ENDDO
227
228	SELECT CASE (LEN_TRIM(cn_rcv_stress(4))) ! 'T' 'U,V' 'U,V,F' 'U,V,I' 'T,F' 'T,I' 'T,U,V'
229	CASE( 1 ) ! 'T'
230	srcv(jprcv_otx1:jprcv_itz2)%clgrid = cltmp(1) ! all oce and ice components on the same unique grid
231	srcv(jprcv_otx1:jprcv_otz1)%laction = .TRUE. ! oce components on 1 grid
232	srcv(jprcv_itx1:jprcv_itz1)%laction = .TRUE. ! ice components on 1 grid
233	CASE( 3 ) ! 'U,V' 'T,F' 'T,I'
234	SELECT CASE (cltmp(1))
235	CASE( 'T' ) ! 'T,F' 'T,I'
236	srcv(jprcv_otx1:jprcv_otz2)%clgrid = cltmp(1) ! oce and ice tau on 2 grids
237	srcv(jprcv_itx1:jprcv_itz2)%clgrid = cltmp(3) ! but oce(ice) components on the same grid
238	srcv(jprcv_otx1:jprcv_otz1)%laction = .TRUE. ! oce components on 1 grid
239	srcv(jprcv_itx1:jprcv_itz1)%laction = .TRUE. ! ice components on 1 grid
240	CASE( 'U' ) ! 'U,V'
241	IF ( cltmp(3) /= 'V' ) CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_rcv_stress(4)' )
242	srcv(jprcv_otx1:jprcv_otz1)%clgrid = cltmp(1) ! oce(ice) components on 2 grids
243	srcv(jprcv_otx2:jprcv_otz2)%clgrid = cltmp(3)
244	srcv(jprcv_itx1:jprcv_itz1)%clgrid = cltmp(1)
245	srcv(jprcv_itx2:jprcv_itz2)%clgrid = cltmp(3)
246	srcv(jprcv_otx1:jprcv_itz2)%laction = .TRUE. ! oce(ice) components on 2 grids
247	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_rcv_stress(4)' )
248	END SELECT
249	CASE( 5 ) ! 'U,V,F' 'U,V,I' 'T,U,V'
250	SELECT CASE (cltmp(1))
251	CASE( 'T' ) ! 'T,U,V'
252	srcv(jprcv_otx1:jprcv_otz2)%clgrid = cltmp(1) ! oce components on 1 grid
253	srcv(jprcv_itx1:jprcv_itz1)%clgrid = cltmp(3) ! ice components on 2 grids
254	srcv(jprcv_itx2:jprcv_itz2)%clgrid = cltmp(5)
255	srcv(jprcv_otx1:jprcv_otz1)%laction = .TRUE. ! oce components on 1 grid
256	srcv(jprcv_itx1:jprcv_itz2)%laction = .TRUE. ! ice components on 2 grids
257	CASE( 'U' ) ! 'U,V,F' 'U,V,I'
258	IF ( cltmp(3) /= 'V' ) CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_rcv_stress(4)' )
259	srcv(jprcv_otx1:jprcv_otz1)%clgrid = cltmp(1) ! oce components on 2 grids
260	srcv(jprcv_otx2:jprcv_otz2)%clgrid = cltmp(3)
261	srcv(jprcv_itx1:jprcv_itz2)%clgrid = cltmp(5) ! ice components on 1 grid
262	srcv(jprcv_otx1:jprcv_otz2)%laction = .TRUE. ! oce components on 2 grids
263	srcv(jprcv_itx1:jprcv_itz1)%laction = .TRUE. ! ice components on 1 grid
264	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_rcv_stress(4)' )
265	END SELECT
266	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_rcv_stress(4)' )
267	END SELECT
268	! force .FALSE. to 3rd component for spherical coodinates
269	IF ( TRIM(cn_rcv_stress(2)) == 'spherical' ) srcv((/jprcv_otz1, jprcv_otz2, jprcv_itz1, jprcv_itz2/))%laction = .FALSE.
270	! force .FALSE. to ice components if not 'oce and ice'
271	IF ( TRIM(cn_rcv_stress(1)) /= 'oce and ice' ) srcv(jprcv_itx1:jprcv_itz2)%laction = .FALSE.
272
273	!-------------------------------------
274	! 10 m wind speed
275	nrcv = nrcv + 1 ; jprcv_w10m = nrcv ; srcv(nrcv)%clname = 'O_Wind10'
276	IF ( TRIM(cn_rcv_w10m) == 'coupled' ) srcv(jprcv_w10m)%laction = .TRUE.
277	! ! +++ ---> A brancher et a blinder dans tke si TRIM(cn_rcv_w10m) == 'none'
278
279	!-------------------------------------
280	! d(Qns)/d(T)
281	nrcv = nrcv + 1 ; jprcv_dqnsdt = nrcv ; srcv(nrcv)%clname = 'O_dQnsdT'
282	IF ( TRIM(cn_rcv_dqnsdt) == 'coupled' ) srcv(jprcv_dqnsdt)%laction = .TRUE.
283
284	!-------------------------------------
285	! Runoff
286	nrcv = nrcv + 1 ; jprcv_rnf = nrcv ; srcv(nrcv)%clname = 'O_Runoff'
287	IF ( TRIM(cn_rcv_rnf) /= 'climato' ) srcv(jprcv_rnf)%laction = .TRUE.
288
289	!-------------------------------------
290	! Calving
291	nrcv = nrcv + 1 ; jprcv_cal = nrcv ; srcv(nrcv)%clname = 'OCalving'
292	IF ( TRIM(cn_rcv_cal) == 'coupled' ) srcv(jprcv_cal)%laction = .TRUE.
293	! +++ ---> A brancher
294
295	!-------------------------------------
296	! fraction of net shortwave radiation which is not absorbed in the
297	! thin surface layer and penetrates inside the ice cover
298	! ( Maykut and Untersteiner, 1971 ; Elbert anbd Curry, 1993 )
299	! Since cloud cover catm not transmitted from atmosphere
300	! ===> defined as constant value -> definition done in sbc_cpl_init
301	!!$ catm(:,:) = 0.
302	!!$ zcatm1(:,:) = 1.0 - catm(:,:) ! fractional cloud cover
303	!!$ fr1_i0(:,:) = 0.18 * zcatm1(:,:) + 0.35 * catm(:,:)
304	!!$ fr2_i0(:,:) = 0.82 * zcatm1(:,:) + 0.65 * catm(:,:)
305	fr1_i0(:,:) = 0.18
306	fr2_i0(:,:) = 0.82
307
308	!
309	!-------------------------------------
310	!-------------------------------------
311	! Define the send interface
312	!-------------------------------------
313	!-------------------------------------
314	!
315	! default definitions of nsnd
316	nsnd = 0
317	ssnd(:)%laction = .FALSE.
318	ssnd(:)%clgrid = 'T'
319	ssnd(:)%nsgn = 1
320
321	!-------------------------------------
322	! Ice fraction
323	nsnd = nsnd + 1 ; jpsnd_fice = nsnd ; ssnd(nsnd)%clname = 'OIceFrac'
324	ssnd(jpsnd_fice)%laction = .TRUE.
325
326	!-------------------------------------
327	! T surf
328	nsnd = nsnd + 1 ; jpsnd_toce = nsnd ; ssnd(nsnd)%clname = 'O_SSTSST'
329	nsnd = nsnd + 1 ; jpsnd_tice = nsnd ; ssnd(nsnd)%clname = 'O_TepIce'
330	nsnd = nsnd + 1 ; jpsnd_tmix = nsnd ; ssnd(nsnd)%clname = 'O_TepMix'
331	SELECT CASE (TRIM(cn_snd_temperature))
332	CASE( 'oce only' ) ; ssnd( jpsnd_toce )%laction = .TRUE.
333	CASE( 'weighted oce and ice' ) ; ssnd( (/jpsnd_toce, jpsnd_tice/) )%laction = .TRUE.
334	CASE( 'mixed oce-ice' ) ; ssnd( jpsnd_tmix )%laction = .TRUE.
335	END SELECT
336
337	!-------------------------------------
338	! Albedo
339	nsnd = nsnd + 1 ; jpsnd_albice = nsnd ; ssnd(nsnd)%clname = 'O_AlbIce'
340	nsnd = nsnd + 1 ; jpsnd_albmix = nsnd ; ssnd(nsnd)%clname = 'O_AlbMix'
341	SELECT CASE (TRIM(cn_snd_albedo))
342	CASE( 'none' ) ! nothing to do
343	CASE( 'weighted ice' ) ; ssnd(jpsnd_albice)%laction = .TRUE.
344	CASE( 'mixed oce-ice' ) ; ssnd(jpsnd_albmix)%laction = .TRUE.
345	CALL albedo_oce (albedo_oce_ov, albedo_oce_cs)
346	! Due to lack of information on nebulosity
347	! albedo = ( albedo clear sky + albedo overcast sky ) / 2
348	cpl_ocean_albedo = ( albedo_oce_cs + albedo_oce_ov ) / 2.
349	END SELECT
350
351	!-------------------------------------
352	! Thickness
353	nsnd = nsnd + 1 ; jpsnd_tckice = nsnd ; ssnd(nsnd)%clname = 'O_IceTck'
354	nsnd = nsnd + 1 ; jpsnd_tcksnw = nsnd ; ssnd(nsnd)%clname = 'O_SnwTck'
355	IF ( TRIM(cn_snd_thickness) == 'weighted ice and snow' ) ssnd( (/jpsnd_tckice, jpsnd_tcksnw/) )%laction = .TRUE.
356
357	!-------------------------------------
358	! Surface current
359	nsnd = nsnd + 1 ; jpsnd_ocx1 = nsnd ; ssnd(nsnd)%clname = 'O_OCurx1'
360	nsnd = nsnd + 1 ; jpsnd_ocy1 = nsnd ; ssnd(nsnd)%clname = 'O_OCury1'
361	nsnd = nsnd + 1 ; jpsnd_ocz1 = nsnd ; ssnd(nsnd)%clname = 'O_OCurz1'
362	nsnd = nsnd + 1 ; jpsnd_ocx2 = nsnd ; ssnd(nsnd)%clname = 'O_OCurx2'
363	nsnd = nsnd + 1 ; jpsnd_ocy2 = nsnd ; ssnd(nsnd)%clname = 'O_OCury2'
364	nsnd = nsnd + 1 ; jpsnd_ocz2 = nsnd ; ssnd(nsnd)%clname = 'O_OCurz2'
365	! Ice velocity
366	nsnd = nsnd + 1 ; jpsnd_ivx1 = nsnd ; ssnd(nsnd)%clname = 'O_IVelx1'
367	nsnd = nsnd + 1 ; jpsnd_ivy1 = nsnd ; ssnd(nsnd)%clname = 'O_IVely1'
368	nsnd = nsnd + 1 ; jpsnd_ivz1 = nsnd ; ssnd(nsnd)%clname = 'O_IVelz1'
369	nsnd = nsnd + 1 ; jpsnd_ivx2 = nsnd ; ssnd(nsnd)%clname = 'O_IVelx2'
370	nsnd = nsnd + 1 ; jpsnd_ivy2 = nsnd ; ssnd(nsnd)%clname = 'O_IVely2'
371	nsnd = nsnd + 1 ; jpsnd_ivz2 = nsnd ; ssnd(nsnd)%clname = 'O_IVelz2'
372
373	ssnd(jpsnd_ocx1:jpsnd_ivz2)%nsgn = -1
374
375	DO i = 1,3
376	cltmp(i) = cn_snd_current_4(i:i)
377	ENDDO
378
379	SELECT CASE (LEN_TRIM(cn_snd_current(4))) ! 'T' 'U,V'
380	CASE( 1 ) ! 'T'
381	ssnd(jpsnd_ocx1:jpsnd_ivz2)%clgrid = cltmp(1) ! all oce and ice components on the same unique grid
382	ssnd(jpsnd_ocx1:jpsnd_ocz1)%laction = .TRUE. ! oce components on 1 grid
383	ssnd(jpsnd_ivx1:jpsnd_ivz1)%laction = .TRUE. ! ice components on 1 grid
384	CASE( 3 ) ! 'U,V'
385	IF ( cltmp(3) /= 'V' ) CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_snd_current(4)' )
386	ssnd(jpsnd_ocx1:jpsnd_ocz1)%clgrid = cltmp(1) ! oce(ice) components on 2 grids
387	ssnd(jpsnd_ocx2:jpsnd_ocz2)%clgrid = cltmp(3)
388	ssnd(jpsnd_ivx1:jpsnd_ivz1)%clgrid = cltmp(1)
389	ssnd(jpsnd_ivx2:jpsnd_ivz2)%clgrid = cltmp(3)
390	ssnd(jpsnd_ocx1:jpsnd_ivz2)%laction = .TRUE. ! oce(ice) components on 2 grids
391	CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of cn_snd_current(4)' )
392	END SELECT
393
394	! force .FALSE. to 3rd component for spherical coodinates
395	IF ( TRIM(cn_snd_current(2)) == 'spherical' ) ssnd((/jpsnd_ocz1, jpsnd_ocz2, jpsnd_ivz1, jpsnd_ivz2/))%laction = .FALSE.
396
397	SELECT CASE (TRIM(cn_snd_current(1)))
398	CASE( 'none' ) ; ssnd( jpsnd_ocx1:jpsnd_ivz2 )%laction = .FALSE.
399	CASE( 'oce only' ) ; ssnd( jpsnd_ivx1:jpsnd_ivz2 )%laction = .FALSE.
400	CASE( 'weighted oce and ice' ) ! nothing to do
401	CASE( 'mixed oce-ice' ) ; ssnd( jpsnd_ivx1:jpsnd_ivz2 )%laction = .FALSE.
402	END SELECT
403	!
404	!-------------------------------------
405	!-------------------------------------
406	CALL cpl_prism_define
407	!-------------------------------------
408	!-------------------------------------
409	!
410
411	END SUBROUTINE sbc_cpl_init
412
413	SUBROUTINE sbc_cpl_rcv( kt )
414
415
416	INTEGER :: kt, isec, info, ji, jj
417
418	!-------------------------------------
419	! Temporary buffers for receiving
420
421	REAL(wp), DIMENSION(jpi,jpj) :: ztmp
422	REAL(wp), DIMENSION(jpi,jpj), SAVE :: qns_mix, qns_tmp, qns_ice_tmp
423	REAL(wp), DIMENSION(jpi,jpj), SAVE :: qsr_mix, qsr_tmp, qsr_ice_tmp
424	REAL(wp), DIMENSION(jpi,jpj), SAVE :: zsnow, zrain, ztevp, zievp, tprecip_tmp, sprecip_tmp, emp_tmp
425	REAL(wp), DIMENSION(jpi,jpj), SAVE :: zotx1, zoty1, zotz1, zotx2, zoty2, zotz2
426	REAL(wp), DIMENSION(jpi,jpj), SAVE :: zitx1, zity1, zitz1, zitx2, zity2, zitz2
427	REAL(wp), DIMENSION(jpi,jpj) :: ztmpx1, ztmpx2, ztmpy1, ztmpy2
428	REAL(wp), DIMENSION(jpi,jpj), SAVE :: wind10_tmp, dqns_ice_tmp, rnfcpl_tmp, ocalving_tmp
429	! Eric: question - ces tableaux tmp ne devraient-ils pas etre initialises a zero ?
430
431	IF( kt == nit000 ) CALL sbc_cpl_init
432
433	isec = ( kt - nit000 ) * NINT(rdttra(1)) ! date of exchanges
434
435	!-------------------------------------
436	! Qsr : we must get qsr and qsr_ice
437	IF ( srcv(jprcv_qsroce)%laction ) CALL cpl_prism_rcv( jprcv_qsroce, isec, qsr_tmp , info )
438	IF ( srcv(jprcv_qsrice)%laction ) CALL cpl_prism_rcv( jprcv_qsrice, isec, qsr_ice_tmp, info )
439	IF ( srcv(jprcv_qsrmix)%laction ) CALL cpl_prism_rcv( jprcv_qsrmix, isec, qsr_mix, info )
440
441
442	!!! Peut etre utiliser
443	! IF ( srcv(jprcv_qsrmix)%laction ) qsr(:,:) = ( qsr_mix(:,:) - freeze(:,:) * qsr_ice(:,:) ) / (1. - freeze(:,:))
444	!!! IF (( srcv(jprcv_qsroce)%laction ) .and. ( srcv(jprcv_qsrice)%laction )) then
445	!!! ztmp(:,:) = qsr_mix(:,:) / (1. - ( cpl_ocean_albedo(:,:)(1. - freeze(:,:)) + freeze(:,:)alb_ice(:,:)))
446	!!! qsr_ice(:,:) = ztmp(:,:) * (1. - alb_ice(:,:))
447	!!! qsr (:,:) = ztmp(:,:) * (1. - cpl_ocean_albedo(:,:))
448	!!! endif
449
450	SELECT CASE (TRIM(cn_rcv_qsr))
451	CASE( 'conservative' )
452	qsr(:,:) = ( qsr_mix(:,:) - freeze(:,:) * qsr_ice_tmp(:,:) ) / (1. - freeze(:,:))
453	qsr_ice(:,:) = qsr_ice_tmp(:,:)
454	CASE( 'oce and ice' )
455	qsr(:,:) = qsr_tmp(:,:)
456	qsr_ice(:,:) = qsr_ice_tmp(:,:)
457	CASE( 'mixed oce-ice' )
458	ztmp(:,:) = qsr_mix(:,:) / (1. - ( cpl_ocean_albedo(:,:)(1. - freeze(:,:)) + freeze(:,:)alb_ice(:,:)))
459	qsr_ice(:,:) = ztmp(:,:) * (1. - alb_ice(:,:))
460	qsr (:,:) = ztmp(:,:) * (1. - cpl_ocean_albedo(:,:))
461	END SELECT
462
463	!-------------------------------------
464	! d(Qns)/d(T)
465	! Must be read before Qns for mixed oce-ice case
466	IF ( srcv(jprcv_dqnsdt)%laction ) CALL cpl_prism_rcv( jprcv_dqnsdt, isec, dqns_ice_tmp, info )
467	dqns_ice(:,:) = dqns_ice_tmp(:,:)
468
469	!-------------------------------------
470	! Qns : we must get qns and qns_ice
471	IF ( srcv(jprcv_qnsoce)%laction ) CALL cpl_prism_rcv( jprcv_qnsoce, isec, qns_tmp , info )
472	IF ( srcv(jprcv_qnsice)%laction ) CALL cpl_prism_rcv( jprcv_qnsice, isec, qns_ice_tmp, info )
473	IF ( srcv(jprcv_qnsmix)%laction ) CALL cpl_prism_rcv( jprcv_qnsmix, isec, qns_mix, info )
474
475	SELECT CASE (TRIM(cn_rcv_qns))
476	CASE( 'conservative' )
477	qns(:,:) = ( qns_mix(:,:) - freeze(:,:) * qns_ice_tmp(:,:) ) / (1. - freeze(:,:))
478	qns_ice(:,:) = qns_ice_tmp(:,:)
479	CASE( 'oce and ice' )
480	qns(:,:) = qns_tmp(:,:)
481	qns_ice(:,:) = qns_ice_tmp(:,:)
482	CASE( 'mixed oce-ice' )
483
484	! Eric >> les valeurs freeze et tn_ice sont elles vraiment disponibles
485	! a chaque pas de temps
486	! dans la version precedente de NEMO, elles l etaient uniquement
487	! pour MOD( kt-1, nfice ) == 0
488
489	ztmp(:,:) = tn_ice(:,:) * freeze(:,:) + ( tn(:,:,1) + rt0 ) * ( 1. - freeze(:,:) )
490	qns(:,:) = qns_mix(:,:) + dqns_ice(:,:) * ( tn(:,:,1) + rt0 - ztmp(:,:) )
491	qns_ice(:,:) = qns_mix(:,:) + dqns_ice(:,:) * ( tn_ice(:,:) - ztmp(:,:) )
492	END SELECT
493
494	!-------------------------------------
495	! Precipitations and Evaporation: we must get emp tprecip and sprecip
496	! sprecip = snow_ice - evap_ice
497	! tprecip = ( rain_ice + snow_ice ) - evap_ice
498	! emp = emp_oce = evap_oce - ( rain_oce + snow_oce ) ... runoff??? ... calving???
499	IF ( srcv(jprcv_snow)%laction ) CALL cpl_prism_rcv( jprcv_snow, isec, zsnow , info ) ! snow
500	IF ( srcv(jprcv_rain)%laction ) CALL cpl_prism_rcv( jprcv_rain, isec, zrain , info ) ! Rain = liquid precipitation
501	IF ( srcv(jprcv_tevp)%laction ) CALL cpl_prism_rcv( jprcv_tevp, isec, ztevp , info ) ! total evaporation (over oce + ice)
502	IF ( srcv(jprcv_ievp)%laction ) CALL cpl_prism_rcv( jprcv_ievp, isec, zievp , info ) ! evaporation over ice (sublimation)
503	IF ( srcv(jprcv_tpre)%laction ) CALL cpl_prism_rcv( jprcv_tpre, isec, tprecip_tmp, info ) ! see above
504	IF ( srcv(jprcv_spre)%laction ) CALL cpl_prism_rcv( jprcv_spre, isec, sprecip_tmp, info ) ! see above
505	IF ( srcv(jprcv_oemp)%laction ) CALL cpl_prism_rcv( jprcv_oemp, isec, emp_tmp , info ) ! see above
506	SELECT CASE (TRIM(cn_rcv_emp))
507	CASE( 'conservative' )
508	sprecip(:,:) = zsnow(:,:) - zievp(:,:)
509	tprecip(:,:) = zrain(:,:) + sprecip(:,:)
510	!!! >> Arnaud pour seb et eric : il me semble qu il y a une erreur emp(:,:) = ( ztevp(:,:) - zievp(:,:)*(1. - freeze(:,:)) )/freeze(:,:) - tprecip(:,:)
511	emp(:,:) = ( ztevp(:,:) - zievp(:,:)*freeze(:,:))/(1. - freeze(:,:)) - tprecip(:,:)
512	!!! << Arnaud
513	CASE( 'oce and ice' )
514	tprecip(:,:) = tprecip_tmp(:,:)
515	sprecip(:,:) = sprecip_tmp(:,:)
516	emp(:,:) = emp_tmp(:,:)
517	CASE( 'mixed oce-ice' )
518	tprecip(:,:) = zrain(:,:) + zsnow(:,:)
519	sprecip(:,:) = zsnow(:,:)
520	emp(:,:) = ztevp(:,:) - tprecip(:,:)
521	END SELECT
522
523	!-------------------------------------
524	! wind stress : we must get utau, vtau, utaui_ice, vtaui_ice
525	! oce stress
526	IF ( srcv(jprcv_otx1)%laction ) CALL cpl_prism_rcv( jprcv_otx1, isec, zotx1, info ) ! oce tau 1st component on 1st grid
527	IF ( srcv(jprcv_oty1)%laction ) CALL cpl_prism_rcv( jprcv_oty1, isec, zoty1, info ) ! oce tau 2nd component on 1st grid
528	IF ( srcv(jprcv_otz1)%laction ) CALL cpl_prism_rcv( jprcv_otz1, isec, zotz1, info ) ! oce tau 3rd component on 1st grid
529	IF ( srcv(jprcv_otx2)%laction ) CALL cpl_prism_rcv( jprcv_otx2, isec, zotx2, info ) ! oce tau 1st component on 2nd grid
530	IF ( srcv(jprcv_oty2)%laction ) CALL cpl_prism_rcv( jprcv_oty2, isec, zoty2, info ) ! oce tau 2nd component on 2nd grid
531	IF ( srcv(jprcv_otz2)%laction ) CALL cpl_prism_rcv( jprcv_otz2, isec, zotz2, info ) ! oce tau 3rd component on 2nd grid
532	! ice stress
533	IF ( srcv(jprcv_itx1)%laction ) CALL cpl_prism_rcv( jprcv_itx1, isec, zitx1, info ) ! ice tau 1st component on 1st grid
534	IF ( srcv(jprcv_ity1)%laction ) CALL cpl_prism_rcv( jprcv_ity1, isec, zity1, info ) ! ice tau 2nd component on 1st grid
535	IF ( srcv(jprcv_itz1)%laction ) CALL cpl_prism_rcv( jprcv_itz1, isec, zitz1, info ) ! ice tau 3rd component on 1st grid
536	IF ( srcv(jprcv_itx2)%laction ) CALL cpl_prism_rcv( jprcv_itx2, isec, zitx2, info ) ! ice tau 1st component on 2nd grid
537	IF ( srcv(jprcv_ity2)%laction ) CALL cpl_prism_rcv( jprcv_ity2, isec, zity2, info ) ! ice tau 2nd component on 2nd grid
538	IF ( srcv(jprcv_itz2)%laction ) CALL cpl_prism_rcv( jprcv_itz2, isec, zitz2, info ) ! ice tau 3rd component on 2nd grid
539	! cartesian to spherical coordinates -> 3 components to 2 components
540	IF ( TRIM(cn_rcv_stress(2)) == 'cartesian' ) THEN
541	! wind stress over ocean
542	SELECT CASE (srcv(jprcv_otx1)%clgrid)
543	CASE( 'T' )
544	CALL geo2oce ( zotx1, zoty1, zotz1, 't', glamt, gphit, ztmpx1, ztmpy1 ) ! 1st and 2nd components on the same grid
545	CASE( 'F' )
546	CALL geo2oce ( zotx1, zoty1, zotz1, 'f', glamf, gphif, ztmpx1, ztmpy1 ) ! 1st and 2nd components on the same grid
547	CASE( 'U' )
548	CALL geo2oce ( zotx1, zoty1, zotz1, 'u', glamu, gphiu, ztmpx1, ztmpy1 ) ! 1st and 2nd components on the 1st grid
549	CALL geo2oce ( zotx2, zoty2, zotz2, 'v', glamv, gphiv, ztmpx2, ztmpy2 ) ! 1st and 2nd components on the 2nd grid
550	zotx2(:,:) = ztmpx2(:,:) ! overwrite 1st component on the 2nd grid
551	zoty2(:,:) = ztmpy2(:,:) ! overwrite 2nd component on the 2nd grid
552	END SELECT
553	zotx1(:,:) = ztmpx1(:,:) ! overwrite 1st component on the 1st grid
554	zoty1(:,:) = ztmpy1(:,:) ! overwrite 2nd component on the 1st grid
555	! wind stress over ice
556	IF ( srcv(jprcv_itx1)%laction ) THEN
557	SELECT CASE (srcv(jprcv_itx1)%clgrid)
558	CASE( 'T' )
559	CALL geo2oce ( zitx1, zity1, zitz1, 't', glamt, gphit, ztmpx1, ztmpy1 ) ! 1st and 2nd comp. on the same grid
560	CASE( 'F' )
561	CALL geo2oce ( zitx1, zity1, zitz1, 'f', glamf, gphif, ztmpx1, ztmpy1 ) ! 1st and 2nd comp. on the same grid
562	CASE( 'U' )
563	CALL geo2oce ( zitx1, zity1, zitz1, 'u', glamu, gphiu, ztmpx1, ztmpy1 ) ! 1st and 2nd comp. on the 1st grid
564	CALL geo2oce ( zitx2, zity2, zitz2, 'v', glamv, gphiv, ztmpx2, ztmpy2 ) ! 1st and 2nd comp. on the 2nd grid
565	zitx2(:,:) = ztmpx2(:,:) ! overwrite 1st comp. on the 2nd grid
566	zity2(:,:) = ztmpy2(:,:) ! overwrite 2nd comp. on the 2nd grid
567	END SELECT
568	zitx1(:,:) = ztmpx1(:,:) ! overwrite 1st comp. on the 1st grid
569	zity1(:,:) = ztmpy1(:,:) ! overwrite 2nd comp. on the 2nd grid
570	ENDIF
571	ENDIF
572
573	! 'eastward-northward' to 'local grid' axes -> rotate the components
574	IF ( TRIM(cn_rcv_stress(3)) == 'eastward-northward' ) THEN ! Oce component
575	CALL rot_rep( zotx1, zoty1, srcv(jprcv_otx1)%clgrid, 'en->i', ztmpx1 ) ! 1st component on the 1st grid
576	zotx1(:,:) = ztmpx1(:,:) ! overwrite 1st component on the 1st grid
577	IF ( srcv(jprcv_otx2)%laction ) THEN
578	CALL rot_rep( zotx2, zoty2, srcv(jprcv_otx2)%clgrid, 'en->j', ztmpy2 ) ! 2nd component on the 2nd grid
579	zoty2(:,:) = ztmpy2(:,:) ! overwrite 2nd component on the 2nd grid
580	ELSE
581	CALL rot_rep( zotx1, zoty1, srcv(jprcv_otx1)%clgrid, 'en->j', ztmpy1 ) ! 2nd component on the 1st grid
582	zoty1(:,:) = ztmpy1(:,:) ! overwrite 2nd component on the 1st grid
583	ENDIF
584	IF ( srcv(jprcv_itx1)%laction ) THEN ! Ice component
585	CALL rot_rep( zitx1, zity1, srcv(jprcv_itx1)%clgrid, 'en->i', ztmpx1 ) ! 1st component on the 1st grid
586	zitx1(:,:) = ztmpx1(:,:) ! overwrite 1st component on the 1st grid
587	IF ( srcv(jprcv_itx2)%laction ) THEN
588	CALL rot_rep( zitx2, zity2, srcv(jprcv_itx2)%clgrid, 'en->j', ztmpy2 ) ! 2nd component on the 2nd grid
589	zity2(:,:) = ztmpy2(:,:) ! overwrite 2nd component on the 2nd grid
590	ELSE
591	CALL rot_rep( zitx1, zity1, srcv(jprcv_itx1)%clgrid, 'en->j', ztmpy1 ) ! 2nd component on the 1st grid
592	zity1(:,:) = ztmpy1(:,:) ! overwrite 2nd component on the 1st grid
593	ENDIF
594	ENDIF
595	ENDIF
596
597	! oce stress must be on U,V grids
598	IF ( srcv(jprcv_otx1)%clgrid == 'T' ) THEN
599	DO jj = 2, jpjm1
600	DO ji = fs_2, fs_jpim1 ! vector opt.
601	utau(ji,jj) = 0.5 * ( zotx1(ji,jj) + zotx1(ji+1,jj ) ) ! T -> U grid
602	vtau(ji,jj) = 0.5 * ( zoty1(ji,jj) + zoty1(ji ,jj+1) ) ! T -> V grid
603	END DO
604	END DO
605	CALL lbc_lnk( utau, 'U', -1. ) ; CALL lbc_lnk( vtau, 'V', -1. )
606	ELSE
607	utau(:,:) = zotx1(:,:)
608	vtau(:,:) = zoty2(:,:)
609	ENDIF
610
611	! make sure we have stress over ice
612	IF ( TRIM(cn_rcv_stress(1)) /= 'oce and ice' ) THEN
613	zitx1(:,:) = zotx1(:,:) ! 1st component on the 1st grid
614	IF ( srcv(jprcv_otx2)%laction ) THEN ; zity2(:,:) = zoty2(:,:) ! 2nd component on the 2nd grid
615	ELSE ; zity1(:,:) = zoty1(:,:) ! 2nd component on the 1st grid
616	ENDIF
617	srcv(jprcv_itx1)%clgrid = srcv(jprcv_otx1)%clgrid ! update grid of the ice component
618	ENDIF
619
620	! ice stress must be on I grid
621	SELECT CASE ( srcv(jprcv_itx1)%clgrid )
622	CASE( 'U' )
623	DO jj = 2, jpjm1
624	DO ji = fs_2, fs_jpim1 ! vector opt.
625	utaui_ice(ji,jj) = 0.5 * ( zitx1(ji-1,jj ) + zitx1(ji-1,jj-1) ) ! U -> I grid
626	vtaui_ice(ji,jj) = 0.5 * ( zity2(ji ,jj-1) + zity2(ji-1,jj-1) ) ! V -> I grid
627	END DO
628	END DO
629	CALL lbc_lnk( utaui_ice, 'I', -1. ) ; CALL lbc_lnk( vtaui_ice, 'I', -1. )
630	CASE( 'F' )
631	DO jj = 2, jpjm1
632	DO ji = fs_2, fs_jpim1 ! vector opt.
633	utaui_ice(ji,jj) = zitx1(ji-1,jj-1) ! F -> I grid
634	vtaui_ice(ji,jj) = zity1(ji-1,jj-1) ! F -> I grid
635	END DO
636	END DO
637	CALL lbc_lnk( utaui_ice, 'I', -1. ) ; CALL lbc_lnk( vtaui_ice, 'I', -1. )
638	CASE( 'T' )
639	DO jj = 2, jpjm1
640	DO ji = fs_2, fs_jpim1 ! vector opt.
641	utaui_ice(ji,jj) = 0.25 * ( zitx1(ji,jj) + zitx1(ji-1,jj) + zitx1(ji,jj-1) + zitx1(ji-1,jj-1) ) ! T -> I grid
642	vtaui_ice(ji,jj) = 0.25 * ( zity1(ji,jj) + zity1(ji-1,jj) + zity1(ji,jj-1) + zity1(ji-1,jj-1) ) ! T -> I grid
643	END DO
644	END DO
645	CALL lbc_lnk( utaui_ice, 'I', -1. ) ; CALL lbc_lnk( vtaui_ice, 'I', -1. )
646	CASE( 'I' )
647	utaui_ice(:,:) = zitx1(:,:)
648	vtaui_ice(:,:) = zity1(:,:)
649	END SELECT
650
651
652	!-------------------------------------
653	! 10 m wind speed
654	! +++ ---> blinder dans tke si TRIM(cn_rcv_w10m) == 'none'
655	IF ( srcv(jprcv_w10m )%laction ) CALL cpl_prism_rcv( jprcv_w10m, isec, wind10_tmp, info )
656	! wind10m(:,:) = wind10_tmp(:,:)
657
658	!-------------------------------------
659	! Runoff
660	! C a u t i o n : runoff must be positive and in kg/m2/s
661	!
662	IF ( srcv(jprcv_rnf )%laction ) CALL cpl_prism_rcv( jprcv_rnf , isec, rnfcpl_tmp, info )
663	rnfcpl(:,:) = rnfcpl_tmp(:,:)
664	!
665	SELECT CASE (TRIM(cn_rcv_rnf))
666	!
667	CASE( 'climato' )
668	!
669	rnfcpl(:,:)=0.
670	!
671	CASE( 'coupled' )
672	!
673	! remove negative runoff
674	!
675	mskpos(:,:)=0 ; mskneg(:,:)=0
676	!
677	WHERE ( rnfcpl(:,:) < 0. ) mskneg(:,:)=1 ; WHERE ( rnfcpl(:,:) > 0. ) mskpos(:,:)=1
678	!
679	zcumulpos=SUM(rnfcpl(:,:)e1t(:,:)e2t(:,:)*mskpos(:,:))
680	zcumulneg=SUM(rnfcpl(:,:)e1t(:,:)e2t(:,:)*mskneg(:,:))
681	!
682	! Eric: pas bien sur de ce mpp_sum la ... Seb ?
683	IF( lk_mpp ) CALL mpp_sum( zcumulpos ) ! sum over the global domain
684	IF( lk_mpp ) CALL mpp_sum( zcumulneg )
685	!
686	IF ( zcumulpos /= 0. ) THEN ; zcumulneg = zcumulneg / zcumulpos
687	ELSE ; zcumulneg = 0
688	ENDIF
689	!
690	! distribute negative runoff on positive runoff grid points
691	!
692	DO jj = 2, jpjm1
693	DO ji = fs_2, fs_jpim1 ! vector opt.
694	rnfcpl(ji,jj) = rnfcpl(ji,jj) * ( 1. + zcumulneg ) * mskpos(ji,jj)
695	ENDDO
696	ENDDO
697	!
698	! add runoff to e-p
699	!
700	emp (:,:) = emp (:,:) - rnfcpl(:,:)
701	emps(:,:) = emps(:,:) - rnfcpl(:,:)
702	!
703	CASE( 'mixed' )
704	!
705	! sum to e-p to be done in sbc_rnf
706	!
707	END SELECT
708	!
709	!-------------------------------------
710	! Calving
711	IF ( srcv(jprcv_cal )%laction ) CALL cpl_prism_rcv( jprcv_cal , isec, ocalving_tmp, info )
712	ocalving(:,:) = ocalving_tmp(:,:)
713	emp (:,:) = emp (:,:) - ABS (ocalving(:,:))
714	emps(:,:) = emps(:,:) - ABS (ocalving(:,:))
715
716	! fraction of net shortwave radiation which is not absorbed in the
717	! thin surface layer and penetrates inside the ice cover
718	! ( Maykut and Untersteiner, 1971 ; Elbert anbd Curry, 1993 )
719	!------------------------------------------------------------------
720	! Since cloud cover catm not transmitted from atmosphere
721	! ===> defined as constant value -> definition done in sbc_cpl_init
722
723	END SUBROUTINE sbc_cpl_rcv
724
725	SUBROUTINE sbc_cpl_snd( kt )
726
727
728	INTEGER :: kt, isec, info, ji, jj
729	REAL(wp), DIMENSION(jpi,jpj) :: ztmp
730	REAL(wp), DIMENSION(jpi,jpj) :: zotx1, zoty1, zotz1, zitx1, zity1, zitz1
731	REAL(wp), DIMENSION(jpi,jpj) :: zotx2, zoty2, zotz2, zitx2, zity2, zitz2
732	REAL(wp), DIMENSION(jpi,jpj) :: ztmpx1, ztmpy1, ztmpx2, ztmpy2
733
734	isec = ( kt - nit000 ) * NINT(rdttra(1)) ! date of exchanges
735
736	!-------------------------------------
737	! Ice fraction
738	IF ( ssnd(jpsnd_fice)%laction ) CALL cpl_prism_snd( jpsnd_fice, isec, freeze, info )
739
740	!-------------------------------------
741	! T surf
742	ztmp(:,:) = tn(:,:,1) + rt0
743	SELECT CASE (TRIM(cn_snd_temperature))
744	CASE( 'oce only' ) ! nothing to do
745	CASE( 'weighted oce and ice' ) ; ztmp = ztmp(:,:) * (1. - freeze(:,:))
746	CASE( 'mixed oce-ice' ) ; ztmp = ztmp(:,:) * (1. - freeze(:,:)) + tn_ice(:,:)*freeze(:,:)
747	END SELECT
748	IF ( ssnd(jpsnd_toce)%laction ) CALL cpl_prism_snd( jpsnd_toce, isec, ztmp, info )
749	IF ( ssnd(jpsnd_tice)%laction ) CALL cpl_prism_snd( jpsnd_tice, isec, tn_ice(:,:) * freeze(:,:), info )
750	IF ( ssnd(jpsnd_tmix)%laction ) CALL cpl_prism_snd( jpsnd_tmix, isec, ztmp, info )
751
752	!-------------------------------------
753	! Albedo
754	IF ( ssnd(jpsnd_albice)%laction ) CALL cpl_prism_snd( jpsnd_albice, isec, alb_ice(:,:) * freeze(:,:), info )
755	IF ( ssnd(jpsnd_albmix)%laction ) THEN
756	CALL cpl_prism_snd( jpsnd_albmix, isec, cpl_ocean_albedo * (1. - freeze(:,:)) + alb_ice(:,:) * freeze(:,:), info )
757	ENDIF
758
759	!-------------------------------------
760	! Thickness
761	IF ( ssnd(jpsnd_tckice)%laction ) CALL cpl_prism_snd( jpsnd_tckice, isec, tckice(:,:) * freeze(:,:), info )
762	IF ( ssnd(jpsnd_tcksnw)%laction ) CALL cpl_prism_snd( jpsnd_tcksnw, isec, tcksnw(:,:) * freeze(:,:), info )
763
764	!-------------------------------------
765	! Surface current
766
767	!-------------------------------------
768	! oce currents
769
770	zotx1(:,:) = un(:,:,1)
771	zoty1(:,:) = vn(:,:,1)
772	zitx1 = utaui_ice
773	zity1 = vtaui_ice
774
775	SELECT CASE (TRIM(cn_snd_current_1))
776	CASE( 'oce only' ) ! nothing to do
777	CASE( 'weighted oce and ice' ) ; zotx1(:,:) = zotx1(:,:) * (1. - freeze(:,:)) ; zoty1(:,:) = zoty1(:,:) * freeze(:,:)
778	zitx1(:,:) = zitx1(:,:) * (1. - freeze(:,:)) ; zity1(:,:) = zity1(:,:) * freeze(:,:)
779	CASE( 'mixed oce-ice' ) ; zotx1(:,:) = zotx1(:,:) * (1. - freeze(:,:)) + zitx1(:,:)freeze(:,:) ; zoty1 = zoty1(:,:) (1. - freeze(:,:)) + zity1(:,:)*freeze(:,:)
780	END SELECT
781
782	zotx2(:,:) = zotx1(:,:)
783	zoty2(:,:) = zoty1(:,:)
784	zitx2(:,:) = zitx1(:,:)
785	zity2(:,:) = zity1(:,:)
786
787	IF ( ssnd(jpsnd_ocx1)%clgrid == 'T' ) THEN
788	! Interpolate current on from U,V grid
789	DO jj = 2, jpjm1
790	DO ji = fs_2, fs_jpim1 ! vector opt.
791	zotx2(ji,jj) = 0.5 * ( zotx1(ji-1,jj ) + zotx1(ji,jj) ) ! U -> T grid
792	zoty2(ji,jj) = 0.5 * ( zoty1(ji ,jj-1) + zoty1(ji,jj) ) ! V -> T grid
793	END DO
794	END DO
795	! Eric: 1 ou -1 pour le troisieme argument de lbc_lnk ?
796	CALL lbc_lnk( zotx2, 'T', 1. ) ; CALL lbc_lnk( zoty2, 'T', 1. )
797	zotx1(:,:) = zotx2(:,:)
798	zoty1(:,:) = zoty2(:,:)
799	!
800	IF ( ssnd(jpsnd_ivx1)%laction ) THEN
801	! Interpolate ice velocities from I grid
802	DO jj = 2, jpjm1
803	DO ji = fs_2, fs_jpim1 ! vector opt.
804	zitx2(ji,jj) = 0.25 * ( zitx1(ji-1,jj ) + zitx1(ji ,jj ) + zitx1(ji-1,jj-1) + zitx1(ji ,jj-1) ) ! I -> T grid
805	zity2(ji,jj) = 0.25 * ( zity1(ji-1,jj ) + zity1(ji ,jj ) + zity1(ji-1,jj-1) + zity1(ji ,jj-1) ) ! I -> T grid
806	END DO
807	END DO
808	CALL lbc_lnk( zitx2, 'T', 1. ) ; CALL lbc_lnk( zity2, 'T', 1. )
809	zitx1(:,:) = zitx2(:,:)
810	zity1(:,:) = zity2(:,:)
811	!
812	ENDIF
813	ELSE IF ( ssnd(jpsnd_ivx1)%laction ) THEN
814	!
815	! Interpolate ice velocities from I grid
816	DO jj = 2, jpjm1
817	DO ji = fs_2, fs_jpim1 ! vector opt.
818	ztmpx1(ji,jj) = 0.5 * ( zitx1(ji+1,jj) + zitx1(ji+1,jj+1) ) ! I -> U grid
819	zitx2(ji,jj) = 0.5 * ( zitx1(ji,jj+1) + zitx1(ji+1,jj+1) ) ! I -> V grid
820	zitx1(ji,jj) = ztmpx1(ji,jj)
821	ztmpx1(ji,jj) = 0.5 * ( zity1(ji+1,jj) + zity1(ji+1,jj+1) ) ! I -> U grid
822	zity2(ji,jj) = 0.5 * ( zity1(ji,jj+1) + zity1(ji+1,jj+1) ) ! I -> V grid
823	zity1(ji,jj) = ztmpx1(ji,jj)
824	END DO
825	END DO
826	CALL lbc_lnk( zitx1, 'U', -1. ) ; CALL lbc_lnk( zity1, 'U', -1. )
827	CALL lbc_lnk( zitx2, 'V', -1. ) ; CALL lbc_lnk( zity2, 'V', -1. )
828	!
829	ENDIF
830
831	! 'local grid' to 'eastward-northward' axes -> rotate the components
832	IF ( TRIM(cn_snd_current(3)) == 'eastward-northward' ) THEN ! Oce component
833	!
834	CALL rot_rep( zotx1, zoty1, ssnd(jpsnd_ocx1)%clgrid, 'ij->e', ztmpx1 ) ! 1st component on the 1st grid
835	zotx1(:,:) = ztmpx1(:,:) ! overwrite 1st component on the 1st grid
836	CALL rot_rep( zotx1, zoty1, srcv(jpsnd_ocx1)%clgrid, 'ij->n', ztmpy1 ) ! 2nd component on the 1st grid
837	zoty1(:,:) = ztmpy1(:,:) ! overwnrite 2nd component on the 1st grid
838	!
839	IF ( ssnd(jpsnd_ocx2)%laction ) THEN
840	CALL rot_rep( zotx2, zoty2, ssnd(jpsnd_ocx2)%clgrid, 'ij->e', ztmpx2 ) ! 1st component on the 2nd grid
841	zotx2(:,:) = ztmpx2(:,:) ! overwrite 2nd component on the 2nd grid
842	CALL rot_rep( zotx2, zoty2, ssnd(jpsnd_ocy2)%clgrid, 'ij->n', ztmpy2 ) ! 2nd component on the 2nd grid
843	zoty2(:,:) = ztmpy2(:,:) ! overwrite 2nd component on the 2nd grid
844	ENDIF
845	!
846	IF ( ssnd(jpsnd_ivx1)%laction ) THEN ! Ice component
847	CALL rot_rep( zitx1, zity1, ssnd(jpsnd_ivx1)%clgrid, 'ij->e', ztmpx1 ) ! 1st component on the 1st grid
848	zitx1(:,:) = ztmpx1(:,:) ! overwrite 1st component on the 1st grid
849	CALL rot_rep( zitx1, zity1, ssnd(jpsnd_ivx1)%clgrid, 'ij->n', ztmpy1 ) ! 2nd component on the 1st grid
850	zity1(:,:) = ztmpy1(:,:) ! overwrite 2nd component on the 1st grid
851	!
852	IF ( ssnd(jpsnd_ivx2)%laction ) THEN
853	CALL rot_rep( zitx2, zity2, ssnd(jpsnd_ivx2)%clgrid, 'ij->e', ztmpx2 ) ! 1st component on the 2nd grid
854	zitx2(:,:) = ztmpx2(:,:) ! overwrite 2nd component on the 2nd grid
855	CALL rot_rep( zitx2, zity2, ssnd(jpsnd_ivx2)%clgrid, 'ij->n', ztmpy2 ) ! 2nd component on the 2nd grid
856	zity2(:,:) = ztmpy2(:,:) ! overwrite 2nd component on the 2nd grid
857	ELSE
858	ENDIF
859	ENDIF
860	ENDIF
861
862	! Eric : Arnaud, je te laisse coder oce2geo !
863	! spherical coordinates to cartesian -> 2 components to 3 components
864	IF ( TRIM(cn_snd_current(2)) == 'cartesian' ) THEN
865	! oceanic currents
866	ztmpx1(:,:) = zotx1(:,:)
867	ztmpy1(:,:) = zoty1(:,:)
868	SELECT CASE (ssnd(jpsnd_ocx1)%clgrid)
869	CASE( 'T' )
870	CALL oce2geo ( ztmpx1, ztmpy1, 't', glamt, gphit, zotx1, zoty1, zotz1 ) ! 1st and 2nd components on the same grid
871	CASE( 'U' )
872	CALL oce2geo ( ztmpx1, ztmpy1, 'u', glamu, gphiu, zotx1, zoty1, zotz1 ) ! 1st and 2nd components on the 1st grid
873	ztmpx2(:,:) = zotx2(:,:)
874	ztmpy2(:,:) = zoty2(:,:)
875	CALL oce2geo ( ztmpx2, ztmpy2, 'v', glamv, gphiv, zotx2, zoty2, zotz2 ) ! 1st and 2nd components on the 2nd grid
876	END SELECT
877	!
878	! ice velocities
879	IF ( ssnd(jpsnd_ivx1)%laction ) THEN
880	ztmpx1(:,:) = zitx1(:,:)
881	ztmpy1(:,:) = zity1(:,:)
882	SELECT CASE (ssnd(jpsnd_ivx1)%clgrid)
883	CASE( 'T' )
884	CALL oce2geo ( ztmpx1, ztmpy1, 't', glamt, gphit, zitx1, zity1, zitz1 ) ! 1st and 2nd components on the same grid
885	CASE( 'U' )
886	CALL oce2geo ( ztmpx1, ztmpy1, 'u', glamu, gphiu, zitx1, zity1, zitz1 ) ! 1st and 2nd components on the 1st grid
887	ztmpx2(:,:) = zitx2(:,:)
888	ztmpy2(:,:) = zity2(:,:)
889	CALL oce2geo ( ztmpx2, ztmpy2, 'v', glamv, gphiv, zitx2, zity2, zitz2 ) ! 1st and 2nd components on the 2nd grid
890	END SELECT
891	ENDIF
892	ENDIF
893
894	IF ( ssnd(jpsnd_ocx1)%laction ) CALL cpl_prism_snd( jpsnd_ocx1, isec, zotx1, info ) ! oce x current first grid
895	IF ( ssnd(jpsnd_ocy1)%laction ) CALL cpl_prism_snd( jpsnd_ocy1, isec, zoty1, info ) ! oce y current first grid
896	IF ( ssnd(jpsnd_ocz1)%laction ) CALL cpl_prism_snd( jpsnd_ocz1, isec, zotz1, info ) ! oce z current first grid
897	IF ( ssnd(jpsnd_ocx2)%laction ) CALL cpl_prism_snd( jpsnd_ocx2, isec, zotx2, info ) ! oce x current second grid
898	IF ( ssnd(jpsnd_ocy2)%laction ) CALL cpl_prism_snd( jpsnd_ocy2, isec, zoty2, info ) ! oce y current second grid
899	IF ( ssnd(jpsnd_ocz2)%laction ) CALL cpl_prism_snd( jpsnd_ocz2, isec, zotz2, info ) ! oce z current second grid
900
901	IF ( ssnd(jpsnd_ivx1)%laction ) CALL cpl_prism_snd( jpsnd_ivx1, isec, zitx1, info ) ! ice x current first grid
902	IF ( ssnd(jpsnd_ivy1)%laction ) CALL cpl_prism_snd( jpsnd_ivy1, isec, zity1, info ) ! ice y current first grid
903	IF ( ssnd(jpsnd_ivz1)%laction ) CALL cpl_prism_snd( jpsnd_ivz1, isec, zitz1, info ) ! ice z current first grid
904	IF ( ssnd(jpsnd_ivx2)%laction ) CALL cpl_prism_snd( jpsnd_ivx2, isec, zitx2, info ) ! ice x current second grid
905	IF ( ssnd(jpsnd_ivy2)%laction ) CALL cpl_prism_snd( jpsnd_ivy2, isec, zity2, info ) ! ice y current second grid
906	IF ( ssnd(jpsnd_ivz2)%laction ) CALL cpl_prism_snd( jpsnd_ivz2, isec, zitz2, info ) ! ice z current second grid
907
908	END SUBROUTINE sbc_cpl_snd
909
910	#else
911	!!----------------------------------------------------------------------
912	!! Dummy routine NO coupling
913	!!----------------------------------------------------------------------
914
915	+++ a verifier ...
916
917
918	#endif
919
920	!!======================================================================
921	END MODULE sbccpl

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

Download in other formats: