Context Navigation

cpl_mod.F90 @ 5434

Last change on this file since 5434 was 1124, checked in by jghattas, 16 years ago

Modification pour couplage conservatif avec NEMO : passage des champs totaux et champs sur la glace au lieu de passage des champs sur l'ocean et champs sur la glace.

Arnaud Caubel

Property svn:eol-style set to native
Property svn:executable set to *
Property svn:keywords set to Author Date Id Revision

File size: 51.1 KB

Line
1	!
2	MODULE cpl_mod
3	!
4	! This module excahanges and transforms all fields that should be recieved or sent to
5	! coupler. The transformation of the fields are done from the grid 1D-array in phylmd
6	! to the regular 2D grid accepted by the coupler. Cumulation of the fields for each
7	! timestep is done in here.
8	!
9	! Each type of surface that recevie fields from the coupler have a subroutine named
10	! cpl_receive_XXX_fields and each surface that have fields to be sent to the coupler
11	! have a subroutine named cpl_send_XXX_fields.
12	!
13	!*************************************************************************************
14
15	! Use statements
16	!*************************************************************************************
17	USE dimphy, ONLY : klon
18	USE mod_phys_lmdz_para
19	USE ioipsl
20	USE iophy
21
22	! The module oasis is always used. Without the cpp key CPP_COUPLE only the parameters
23	! in the module are compiled and not the subroutines.
24	USE oasis
25	USE write_field_phy
26
27	! Global attributes
28	!*************************************************************************************
29	IMPLICIT NONE
30	PRIVATE
31
32	! All subroutine are public except cpl_send_all and cpl_receive_all
33	PUBLIC :: cpl_init, cpl_receive_ocean_fields, cpl_receive_seaice_fields, &
34	cpl_send_ocean_fields, cpl_send_seaice_fields, cpl_send_land_fields, &
35	cpl_send_landice_fields, gath2cpl
36
37
38	! Declaration of module variables
39	!*************************************************************************************
40	! variable for coupling period
41	INTEGER, SAVE :: nexca
42	!$OMP THREADPRIVATE(nexca)
43
44	! variables for cumulating fields during a coupling periode :
45	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: cpl_sols, cpl_nsol, cpl_rain
46	!$OMP THREADPRIVATE(cpl_sols,cpl_nsol,cpl_rain)
47	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: cpl_snow, cpl_evap, cpl_tsol
48	!$OMP THREADPRIVATE(cpl_snow,cpl_evap,cpl_tsol)
49	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: cpl_fder, cpl_albe, cpl_taux
50	!$OMP THREADPRIVATE(cpl_fder,cpl_albe,cpl_taux)
51	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: cpl_windsp
52	!$OMP THREADPRIVATE(cpl_windsp)
53	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: cpl_tauy
54	!$OMP THREADPRIVATE(cpl_tauy)
55	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: cpl_rriv2D, cpl_rcoa2D, cpl_rlic2D
56	!$OMP THREADPRIVATE(cpl_rriv2D,cpl_rcoa2D,cpl_rlic2D)
57
58	! variables read from coupler :
59	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: read_sst ! sea surface temperature
60	!$OMP THREADPRIVATE(read_sst)
61	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: read_sit ! sea ice temperature
62	!$OMP THREADPRIVATE(read_sit)
63	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: read_sic ! sea ice fraction
64	!$OMP THREADPRIVATE(read_sic)
65	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: read_alb_sic ! albedo at sea ice
66	!$OMP THREADPRIVATE(read_alb_sic)
67
68	! fraction for different surface, saved during whole coupling period
69	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: pctsrf_sav
70	!$OMP THREADPRIVATE(pctsrf_sav)
71	INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: unity
72	!$OMP THREADPRIVATE(unity)
73	INTEGER, SAVE :: nidct, nidcs
74	!$OMP THREADPRIVATE(nidct,nidcs)
75
76	! variables to be sent to the coupler
77	REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_sols2D, cpl_nsol2D, cpl_rain2D
78	!$OMP THREADPRIVATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D)
79	REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_snow2D, cpl_evap2D, cpl_tsol2D
80	!$OMP THREADPRIVATE(cpl_snow2D, cpl_evap2D, cpl_tsol2D)
81	REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_fder2D, cpl_albe2D
82	!$OMP THREADPRIVATE(cpl_fder2D, cpl_albe2D)
83	REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_taux2D, cpl_tauy2D
84	!$OMP THREADPRIVATE(cpl_taux2D, cpl_tauy2D)
85	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: cpl_windsp2D
86	!$OMP THREADPRIVATE(cpl_windsp2D)
87
88
89	CONTAINS
90	!
91	!************************************************************************************
92	!
93	SUBROUTINE cpl_init(dtime, rlon, rlat)
94
95	INCLUDE "dimensions.h"
96	INCLUDE "indicesol.h"
97	INCLUDE "control.h"
98	INCLUDE "temps.h"
99	INCLUDE "iniprint.h"
100
101	! Input arguments
102	!*************************************************************************************
103	REAL, INTENT(IN) :: dtime
104	REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
105
106	! Local variables
107	!*************************************************************************************
108	INTEGER :: error, sum_error, ig, i
109	INTEGER :: jf, nhoridct
110	INTEGER :: nhoridcs
111	INTEGER :: idtime
112	INTEGER :: idayref
113	INTEGER :: npas ! only for OASIS2
114	REAL :: zjulian
115	REAL, DIMENSION(iim,jjm+1) :: zx_lon, zx_lat
116	CHARACTER(len = 20) :: modname = 'cpl_init'
117	CHARACTER(len = 80) :: abort_message
118	CHARACTER(len=80) :: clintocplnam, clfromcplnam
119
120	!*************************************************************************************
121	! Calculate coupling period
122	!
123	!*************************************************************************************
124
125	npas = itaufin/ iphysiq
126	nexca = 86400 / dtime
127	WRITE(lunout,*)' ##### Ocean couple #####'
128	WRITE(lunout,*)' Valeurs des pas de temps'
129	WRITE(lunout,*)' npas = ', npas
130	WRITE(lunout,*)' nexca = ', nexca
131
132	!*************************************************************************************
133	! Allocate variables
134	!
135	!*************************************************************************************
136	error = 0
137	sum_error = 0
138
139	ALLOCATE(unity(klon), stat = error)
140	sum_error = sum_error + error
141	ALLOCATE(pctsrf_sav(klon,nbsrf), stat = error)
142	sum_error = sum_error + error
143	ALLOCATE(cpl_sols(klon,2), stat = error)
144	sum_error = sum_error + error
145	ALLOCATE(cpl_nsol(klon,2), stat = error)
146	sum_error = sum_error + error
147	ALLOCATE(cpl_rain(klon,2), stat = error)
148	sum_error = sum_error + error
149	ALLOCATE(cpl_snow(klon,2), stat = error)
150	sum_error = sum_error + error
151	ALLOCATE(cpl_evap(klon,2), stat = error)
152	sum_error = sum_error + error
153	ALLOCATE(cpl_tsol(klon,2), stat = error)
154	sum_error = sum_error + error
155	ALLOCATE(cpl_fder(klon,2), stat = error)
156	sum_error = sum_error + error
157	ALLOCATE(cpl_albe(klon,2), stat = error)
158	sum_error = sum_error + error
159	ALLOCATE(cpl_taux(klon,2), stat = error)
160	sum_error = sum_error + error
161	ALLOCATE(cpl_windsp(klon,2), stat = error)
162	sum_error = sum_error + error
163	ALLOCATE(cpl_tauy(klon,2), stat = error)
164	sum_error = sum_error + error
165	ALLOCATE(cpl_rriv2D(iim,jj_nb), stat=error)
166	sum_error = sum_error + error
167	ALLOCATE(cpl_rcoa2D(iim,jj_nb), stat=error)
168	sum_error = sum_error + error
169	ALLOCATE(cpl_rlic2D(iim,jj_nb), stat=error)
170	sum_error = sum_error + error
171	ALLOCATE(read_sst(iim, jj_nb), stat = error)
172	sum_error = sum_error + error
173	ALLOCATE(read_sic(iim, jj_nb), stat = error)
174	sum_error = sum_error + error
175	ALLOCATE(read_sit(iim, jj_nb), stat = error)
176	sum_error = sum_error + error
177	ALLOCATE(read_alb_sic(iim, jj_nb), stat = error)
178	sum_error = sum_error + error
179
180	IF (sum_error /= 0) THEN
181	abort_message='Pb allocation variables couplees'
182	CALL abort_gcm(modname,abort_message,1)
183	ENDIF
184	!*************************************************************************************
185	! Initialize the allocated varaibles
186	!
187	!*************************************************************************************
188	DO ig = 1, klon
189	unity(ig) = ig
190	ENDDO
191	pctsrf_sav = 0.
192
193	cpl_sols = 0. ; cpl_nsol = 0. ; cpl_rain = 0. ; cpl_snow = 0.
194	cpl_evap = 0. ; cpl_tsol = 0. ; cpl_fder = 0. ; cpl_albe = 0.
195	cpl_taux = 0. ; cpl_tauy = 0. ; cpl_rriv2D = 0. ; cpl_rcoa2D = 0.
196	cpl_rlic2D = 0. ; cpl_windsp = 0.
197
198	!*************************************************************************************
199	! Initialize coupling
200	!
201	!*************************************************************************************
202	idtime = INT(dtime)
203	#ifdef CPP_COUPLE
204	CALL inicma
205	#endif
206
207	!*************************************************************************************
208	! initialize NetCDF output
209	!
210	!*************************************************************************************
211	IF (is_sequential) THEN
212	idayref = day_ini
213	CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
214	CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
215	DO i = 1, iim
216	zx_lon(i,1) = rlon(i+1)
217	zx_lon(i,jjm+1) = rlon(i+1)
218	ENDDO
219	CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
220	clintocplnam="cpl_atm_tauflx"
221	CALL histbeg(clintocplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),&
222	1,iim,1,jjm+1, itau_phy,zjulian,dtime,nhoridct,nidct)
223	! no vertical axis
224	CALL histdef(nidct, 'tauxe','tauxe', &
225	"-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
226	CALL histdef(nidct, 'tauyn','tauyn', &
227	"-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
228	CALL histdef(nidct, 'tmp_lon','tmp_lon', &
229	"-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
230	CALL histdef(nidct, 'tmp_lat','tmp_lat', &
231	"-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
232	DO jf=1,jpflda2o1 + jpflda2o2
233	CALL histdef(nidct, cl_writ(jf),cl_writ(jf), &
234	"-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
235	END DO
236	CALL histend(nidct)
237	CALL histsync(nidct)
238
239	clfromcplnam="cpl_atm_sst"
240	CALL histbeg(clfromcplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, &
241	0,zjulian,dtime,nhoridcs,nidcs)
242	! no vertical axis
243	DO jf=1,jpfldo2a
244	CALL histdef(nidcs, cl_read(jf),cl_read(jf), &
245	"-",iim, jjm+1, nhoridcs, 1, 1, 1, -99, 32, "inst", dtime,dtime)
246	END DO
247	CALL histend(nidcs)
248	CALL histsync(nidcs)
249
250	ENDIF ! is_sequential
251
252	END SUBROUTINE cpl_init
253
254	!
255	!*************************************************************************************
256	!
257
258	SUBROUTINE cpl_receive_all(itime, dtime, pctsrf)
259	! This subroutine reads from coupler for both ocean and seaice
260	! 4 fields : read_sst, read_sic, read_sit and read_alb_sic.
261
262	USE surface_data, ONLY : version_ocean
263	INCLUDE "indicesol.h"
264	INCLUDE "temps.h"
265	INCLUDE "iniprint.h"
266	INCLUDE "YOMCST.h"
267	INCLUDE "dimensions.h"
268
269	! Input arguments
270	!************************************************************************************
271	INTEGER, INTENT(IN) :: itime
272	REAL, INTENT(IN) :: dtime
273	REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
274
275	! Local variables
276	!************************************************************************************
277	INTEGER :: j, ig, il_time_secs
278	INTEGER :: itau_w
279	INTEGER, DIMENSION(iim*(jjm+1)) :: ndexcs
280	CHARACTER(len = 20) :: modname = 'cpl_receive_all'
281	CHARACTER(len = 80) :: abort_message
282	REAL, DIMENSION(klon) :: read_sic1D
283	REAL, DIMENSION(iim,jj_nb,jpfldo2a) :: tab_read_flds
284	REAL, DIMENSION(iim,jj_nb) :: read_sic
285
286	!*************************************************************************************
287	! Start calculation
288	! Get fields from coupler
289	!
290	!*************************************************************************************
291
292	#ifdef CPP_COUPLE
293	il_time_secs=(itime-1)*dtime
294	CALL fromcpl(il_time_secs, tab_read_flds)
295	#endif
296
297	! NetCDF output of received fields
298	IF (is_sequential) THEN
299	ndexcs(:) = 0
300	itau_w = itau_phy + itime
301	DO ig = 1, jpfldo2a
302	CALL histwrite(nidcs,cl_read(ig),itau_w,tab_read_flds(:,:,ig),iim*(jjm+1),ndexcs)
303	END DO
304	ENDIF
305
306	! Save each field in a 2D array.
307
308	read_sst(:,:) = tab_read_flds(:,:,1) ! Sea surface temperature
309	read_sic(:,:) = tab_read_flds(:,:,2) ! Sea ice concentration
310	read_alb_sic(:,:) = tab_read_flds(:,:,3) ! Albedo at sea ice
311	read_sit(:,:) = tab_read_flds(:,:,4) ! Sea ice temperature
312
313	!*************************************************************************************
314	! Temperature and albedo are weighted with the fraction of sea-ice(read-sic)
315	!
316	!*************************************************************************************
317	DO j = 1, jj_nb
318	DO ig = 1, iim
319	IF (ABS(1. - read_sic(ig,j)) < 0.00001) THEN
320	read_sst(ig,j) = RTT - 1.8
321	read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
322	read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
323	ELSE IF (ABS(read_sic(ig,j)) < 0.00001) THEN
324	read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
325	read_sit(ig,j) = read_sst(ig,j)
326	read_alb_sic(ig,j) = 0.6
327	ELSE
328	read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
329	read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
330	read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
331	ENDIF
332	ENDDO
333	ENDDO
334
335	!*************************************************************************************
336	! Transform seaice fraction, read_sic into pctsrf_sav
337	!
338	!*************************************************************************************
339	CALL cpl2gath(read_sic, read_sic1D, klon, unity)
340
341	DO ig = 1, klon
342	! treatment only of ocean and/or seaice points
343	IF (pctsrf(ig,is_oce) > epsfra .OR. &
344	pctsrf(ig,is_sic) > epsfra) THEN
345	pctsrf_sav(ig,is_sic) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
346	* read_sic1D(ig)
347	pctsrf_sav(ig,is_oce) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
348	- pctsrf_sav(ig,is_sic)
349	ENDIF
350	ENDDO
351
352	!*************************************************************************************
353	! To avoid round up problems
354	!
355	!*************************************************************************************
356	WHERE (ABS(pctsrf_sav(:,is_sic)) .LE. 2.*EPSILON(pctsrf_sav(1,is_sic)))
357	pctsrf_sav(:,is_sic) = 0.
358	pctsrf_sav(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
359	ENDWHERE
360	WHERE (ABS(pctsrf_sav(:,is_oce)) .LE. 2.*EPSILON(pctsrf_sav(1,is_oce)))
361	pctsrf_sav(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
362	pctsrf_sav(:,is_oce) = 0.
363	ENDWHERE
364	IF (MINVAL(pctsrf_sav(:,is_oce)) < 0.) THEN
365	WRITE(,)'Pb fraction ocean inferieure a 0'
366	WRITE(,)'au point ',MINLOC(pctsrf_sav(:,is_oce))
367	WRITE(,)'valeur = ',MINVAL(pctsrf_sav(:,is_oce))
368	abort_message = 'voir ci-dessus'
369	CALL abort_gcm(modname,abort_message,1)
370	ENDIF
371	IF (MINVAL(pctsrf_sav(:,is_sic)) < 0.) THEN
372	WRITE(,)'Pb fraction glace inferieure a 0'
373	WRITE(,)'au point ',MINLOC(pctsrf_sav(:,is_sic))
374	WRITE(,)'valeur = ',MINVAL(pctsrf_sav(:,is_sic))
375	abort_message = 'voir ci-dessus'
376	CALL abort_gcm(modname,abort_message,1)
377	ENDIF
378
379	END SUBROUTINE cpl_receive_all
380	!
381	!*************************************************************************************
382	!
383	SUBROUTINE cpl_receive_ocean_fields(itime, dtime, knon, knindex, pctsrf, &
384	tsurf_new, pctsrf_oce)
385	!
386	! This routine reads, if first time step in a coupling period, all fields reveived from
387	! coupler for all types of surfaces. It returns the fields for the ocean surface which
388	! are the sea surface temperature and the fraction of ocean.
389	! The fields are transformed into 1D arrays with valid points :
390	! tsurf_new(1:knon), pctsrf(1:klon).
391	!
392	INCLUDE "indicesol.h"
393
394	! Input arguments
395	!*************************************************************************************
396	INTEGER, INTENT(IN) :: itime
397	REAL, INTENT(IN) :: dtime
398	INTEGER, INTENT(IN) :: knon
399	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
400	REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
401
402	! Output arguments
403	!*************************************************************************************
404	REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new
405	REAL, DIMENSION(klon), INTENT(OUT) :: pctsrf_oce
406
407	!*************************************************************************************
408	! If first time step in a coupling period receive all fields for all types
409	! of surfaces from coupler : read_sst, read_sit, read_alb_sic and pctsrf_sav.
410	!
411	!*************************************************************************************
412
413	IF (MOD(itime, nexca) == 1) CALL cpl_receive_all(itime, dtime, pctsrf)
414
415
416	!*************************************************************************************
417	! Transform read_sst into compressed 1D variable tsurf_new
418	!
419	!*************************************************************************************
420	CALL cpl2gath(read_sst, tsurf_new, knon, knindex)
421	pctsrf_oce(:) = pctsrf_sav(:,is_oce)
422
423
424	END SUBROUTINE cpl_receive_ocean_fields
425	!
426	!*************************************************************************************
427	!
428	SUBROUTINE cpl_receive_seaice_fields(knon, knindex, &
429	tsurf_new, alb_new, pctsrf_sic)
430	!
431	! This routine returns the fields for the seaice that have been read from the coupler
432	! (done earlier with cpl_receive_ocean_fields). These fields are the temperature and
433	! albedo at sea ice surface and fraction of sea ice.
434	! The fields are transformed into 1D arrays with valid points :
435	! tsurf_new(1:knon), alb_new(1:knon), pctsrf(1:klon).
436	!
437	INCLUDE "indicesol.h"
438
439	! Input arguments
440	!*************************************************************************************
441	INTEGER, INTENT(IN) :: knon
442	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
443
444	! Output arguments
445	!*************************************************************************************
446	REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new
447	REAL, DIMENSION(klon), INTENT(OUT) :: alb_new
448	REAL, DIMENSION(klon), INTENT(OUT) :: pctsrf_sic
449
450
451	!*************************************************************************************
452	! Transform fields read from coupler from 2D into compressed 1D variables
453	!
454	!*************************************************************************************
455	CALL cpl2gath(read_sit, tsurf_new, knon, knindex)
456	CALL cpl2gath(read_alb_sic, alb_new, knon, knindex)
457	pctsrf_sic(:) = pctsrf_sav(:,is_sic)
458
459	END SUBROUTINE cpl_receive_seaice_fields
460
461	!
462	!*************************************************************************************
463	!
464
465	SUBROUTINE cpl_send_ocean_fields(itime, knon, knindex, &
466	swdown, lwdown, fluxlat, fluxsens, &
467	precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy, windsp)
468	!
469	! This subroutine cumulates some fields for each time-step during a coupling
470	! period. At last time-step in a coupling period the fields are transformed to the
471	! grid accepted by the coupler. No sending to the coupler will be done from here
472	! (it is done in cpl_send_seaice_fields).
473	!
474	INCLUDE "indicesol.h"
475	INCLUDE "dimensions.h"
476
477	! Input arguments
478	!*************************************************************************************
479	INTEGER, INTENT(IN) :: itime
480	INTEGER, INTENT(IN) :: knon
481	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
482	REAL, DIMENSION(klon), INTENT(IN) :: swdown, lwdown
483	REAL, DIMENSION(klon), INTENT(IN) :: fluxlat, fluxsens
484	REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow
485	REAL, DIMENSION(klon), INTENT(IN) :: evap, tsurf, fder, albsol
486	REAL, DIMENSION(klon), INTENT(IN) :: taux, tauy, windsp
487
488	! Local variables
489	!*************************************************************************************
490	INTEGER :: cpl_index, ig
491	INTEGER :: error, sum_error
492	CHARACTER(len = 25) :: modname = 'cpl_send_ocean_fields'
493	CHARACTER(len = 80) :: abort_message
494
495	!*************************************************************************************
496	! Start calculation
497	! The ocean points are saved with second array index=1
498	!
499	!*************************************************************************************
500	cpl_index = 1
501
502	!*************************************************************************************
503	! Reset fields to zero in the beginning of a new coupling period
504	!
505	!*************************************************************************************
506	IF (MOD(itime, nexca) == 1) THEN
507	cpl_sols(:,cpl_index) = 0.0
508	cpl_nsol(:,cpl_index) = 0.0
509	cpl_rain(:,cpl_index) = 0.0
510	cpl_snow(:,cpl_index) = 0.0
511	cpl_evap(:,cpl_index) = 0.0
512	cpl_tsol(:,cpl_index) = 0.0
513	cpl_fder(:,cpl_index) = 0.0
514	cpl_albe(:,cpl_index) = 0.0
515	cpl_taux(:,cpl_index) = 0.0
516	cpl_tauy(:,cpl_index) = 0.0
517	cpl_windsp(:,cpl_index) = 0.0
518	ENDIF
519
520	!*************************************************************************************
521	! Cumulate at each time-step
522	!
523	!*************************************************************************************
524	DO ig = 1, knon
525	cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
526	swdown(ig) / FLOAT(nexca)
527	cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
528	(lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca)
529	cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
530	precip_rain(ig) / FLOAT(nexca)
531	cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
532	precip_snow(ig) / FLOAT(nexca)
533	cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
534	evap(ig) / FLOAT(nexca)
535	cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
536	tsurf(ig) / FLOAT(nexca)
537	cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
538	fder(ig) / FLOAT(nexca)
539	cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
540	albsol(ig) / FLOAT(nexca)
541	cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
542	taux(ig) / FLOAT(nexca)
543	cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
544	tauy(ig) / FLOAT(nexca)
545	cpl_windsp(ig,cpl_index) = cpl_windsp(ig,cpl_index) + &
546	windsp(ig) / FLOAT(nexca)
547	ENDDO
548
549	!*************************************************************************************
550	! If the time-step corresponds to the end of coupling period the
551	! fields are transformed to the 2D grid.
552	! No sending to the coupler (it is done from cpl_send_seaice_fields).
553	!
554	!*************************************************************************************
555	IF (MOD(itime, nexca) == 0) THEN
556
557	IF (.NOT. ALLOCATED(cpl_sols2D)) THEN
558	sum_error = 0
559	ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error)
560	sum_error = sum_error + error
561	ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error)
562	sum_error = sum_error + error
563	ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error)
564	sum_error = sum_error + error
565	ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error)
566	sum_error = sum_error + error
567	ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error)
568	sum_error = sum_error + error
569	ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error)
570	sum_error = sum_error + error
571	ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error)
572	sum_error = sum_error + error
573	ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error)
574	sum_error = sum_error + error
575	ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error)
576	sum_error = sum_error + error
577	ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error)
578	sum_error = sum_error + error
579	ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error)
580	sum_error = sum_error + error
581
582	IF (sum_error /= 0) THEN
583	abort_message='Pb allocation variables couplees pour l''ecriture'
584	CALL abort_gcm(modname,abort_message,1)
585	ENDIF
586	ENDIF
587
588
589	CALL gath2cpl(cpl_sols(1,cpl_index), cpl_sols2D(1,1,cpl_index), &
590	knon, knindex)
591
592	CALL gath2cpl(cpl_nsol(1,cpl_index), cpl_nsol2D(1,1,cpl_index), &
593	knon, knindex)
594
595	CALL gath2cpl(cpl_rain(1,cpl_index), cpl_rain2D(1,1,cpl_index), &
596	knon, knindex)
597
598	CALL gath2cpl(cpl_snow(1,cpl_index), cpl_snow2D(1,1,cpl_index), &
599	knon, knindex)
600
601	CALL gath2cpl(cpl_evap(1,cpl_index), cpl_evap2D(1,1,cpl_index), &
602	knon, knindex)
603
604	! cpl_tsol2D(:,:,:) not used!
605	CALL gath2cpl(cpl_tsol(1,cpl_index), cpl_tsol2D(1,1, cpl_index), &
606	knon, knindex)
607
608	! cpl_fder2D(:,:,1) not used, only cpl_fder(:,:,2)!
609	CALL gath2cpl(cpl_fder(1,cpl_index), cpl_fder2D(1,1,cpl_index), &
610	knon, knindex)
611
612	! cpl_albe2D(:,:,:) not used!
613	CALL gath2cpl(cpl_albe(1,cpl_index), cpl_albe2D(1,1,cpl_index), &
614	knon, knindex)
615
616	CALL gath2cpl(cpl_taux(1,cpl_index), cpl_taux2D(1,1,cpl_index), &
617	knon, knindex)
618
619	CALL gath2cpl(cpl_tauy(1,cpl_index), cpl_tauy2D(1,1,cpl_index), &
620	knon, knindex)
621
622	CALL gath2cpl(cpl_windsp(1,cpl_index), cpl_windsp2D(1,1), &
623	knon, knindex)
624
625	ENDIF
626
627	END SUBROUTINE cpl_send_ocean_fields
628
629	!
630	!*************************************************************************************
631	!
632
633	SUBROUTINE cpl_send_seaice_fields(itime, dtime, knon, knindex, &
634	pctsrf, lafin, rlon, rlat, &
635	swdown, lwdown, fluxlat, fluxsens, &
636	precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy)
637	!
638	! This subroutine cumulates some fields for each time-step during a coupling
639	! period. At last time-step in a coupling period the fields are transformed to the
640	! grid accepted by the coupler. All fields for all types of surfaces are sent to
641	! the coupler.
642	!
643	INCLUDE "indicesol.h"
644	INCLUDE "dimensions.h"
645
646	! Input arguments
647	!*************************************************************************************
648	INTEGER, INTENT(IN) :: itime
649	INTEGER, INTENT(IN) :: knon
650	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
651	REAL, INTENT(IN) :: dtime
652	REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
653	REAL, DIMENSION(klon), INTENT(IN) :: swdown, lwdown
654	REAL, DIMENSION(klon), INTENT(IN) :: fluxlat, fluxsens
655	REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow
656	REAL, DIMENSION(klon), INTENT(IN) :: evap, tsurf, fder
657	REAL, DIMENSION(klon), INTENT(IN) :: albsol, taux, tauy
658	REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
659	LOGICAL, INTENT(IN) :: lafin
660
661	! Local variables
662	!*************************************************************************************
663	INTEGER :: cpl_index, ig
664	INTEGER :: error, sum_error
665	CHARACTER(len = 25) :: modname = 'cpl_send_seaice_fields'
666	CHARACTER(len = 80) :: abort_message
667
668
669	!*************************************************************************************
670	! Start calulation
671	! The sea-ice points are saved with second array index=2
672	!
673	!*************************************************************************************
674	cpl_index = 2
675
676	!*************************************************************************************
677	! Reset fields to zero in the beginning of a new coupling period
678	!
679	!*************************************************************************************
680	IF (MOD(itime, nexca) == 1) THEN
681	cpl_sols(:,cpl_index) = 0.0
682	cpl_nsol(:,cpl_index) = 0.0
683	cpl_rain(:,cpl_index) = 0.0
684	cpl_snow(:,cpl_index) = 0.0
685	cpl_evap(:,cpl_index) = 0.0
686	cpl_tsol(:,cpl_index) = 0.0
687	cpl_fder(:,cpl_index) = 0.0
688	cpl_albe(:,cpl_index) = 0.0
689	cpl_taux(:,cpl_index) = 0.0
690	cpl_tauy(:,cpl_index) = 0.0
691	ENDIF
692
693	!*************************************************************************************
694	! Cumulate at each time-step
695	!
696	!*************************************************************************************
697	DO ig = 1, knon
698	cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
699	swdown(ig) / FLOAT(nexca)
700	cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
701	(lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca)
702	cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
703	precip_rain(ig) / FLOAT(nexca)
704	cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
705	precip_snow(ig) / FLOAT(nexca)
706	cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
707	evap(ig) / FLOAT(nexca)
708	cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
709	tsurf(ig) / FLOAT(nexca)
710	cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
711	fder(ig) / FLOAT(nexca)
712	cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
713	albsol(ig) / FLOAT(nexca)
714	cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
715	taux(ig) / FLOAT(nexca)
716	cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
717	tauy(ig) / FLOAT(nexca)
718	ENDDO
719
720	!*************************************************************************************
721	! If the time-step corresponds to the end of coupling period the
722	! fields are transformed to the 2D grid and all fields are sent to coupler.
723	!
724	!*************************************************************************************
725	IF (MOD(itime, nexca) == 0) THEN
726	IF (.NOT. ALLOCATED(cpl_sols2D)) THEN
727	sum_error = 0
728	ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error)
729	sum_error = sum_error + error
730	ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error)
731	sum_error = sum_error + error
732	ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error)
733	sum_error = sum_error + error
734	ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error)
735	sum_error = sum_error + error
736	ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error)
737	sum_error = sum_error + error
738	ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error)
739	sum_error = sum_error + error
740	ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error)
741	sum_error = sum_error + error
742	ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error)
743	sum_error = sum_error + error
744	ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error)
745	sum_error = sum_error + error
746	ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error)
747	sum_error = sum_error + error
748	ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error)
749	sum_error = sum_error + error
750
751	IF (sum_error /= 0) THEN
752	abort_message='Pb allocation variables couplees pour l''ecriture'
753	CALL abort_gcm(modname,abort_message,1)
754	ENDIF
755	ENDIF
756
757	CALL gath2cpl(cpl_sols(1,cpl_index), cpl_sols2D(1,1,cpl_index), &
758	knon, knindex)
759
760	CALL gath2cpl(cpl_nsol(1,cpl_index), cpl_nsol2D(1,1,cpl_index), &
761	knon, knindex)
762
763	CALL gath2cpl(cpl_rain(1,cpl_index), cpl_rain2D(1,1,cpl_index), &
764	knon, knindex)
765
766	CALL gath2cpl(cpl_snow(1,cpl_index), cpl_snow2D(1,1,cpl_index), &
767	knon, knindex)
768
769	CALL gath2cpl(cpl_evap(1,cpl_index), cpl_evap2D(1,1,cpl_index), &
770	knon, knindex)
771
772	! cpl_tsol2D(:,:,:) not used!
773	CALL gath2cpl(cpl_tsol(1,cpl_index), cpl_tsol2D(1,1, cpl_index), &
774	knon, knindex)
775
776	CALL gath2cpl(cpl_fder(1,cpl_index), cpl_fder2D(1,1,cpl_index), &
777	knon, knindex)
778
779	! cpl_albe2D(:,:,:) not used!
780	CALL gath2cpl(cpl_albe(1,cpl_index), cpl_albe2D(1,1,cpl_index), &
781	knon, knindex)
782
783	CALL gath2cpl(cpl_taux(1,cpl_index), cpl_taux2D(1,1,cpl_index), &
784	knon, knindex)
785
786	CALL gath2cpl(cpl_tauy(1,cpl_index), cpl_tauy2D(1,1,cpl_index), &
787	knon, knindex)
788
789	! Send all fields
790	CALL cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat)
791	ENDIF
792
793	END SUBROUTINE cpl_send_seaice_fields
794
795	!
796	!*************************************************************************************
797	!
798
799	SUBROUTINE cpl_send_land_fields(itime, knon, knindex, rriv_in, rcoa_in)
800	!
801	! This subroutine cumulates some fields for each time-step during a coupling
802	! period. At last time-step in a coupling period the fields are transformed to the
803	! grid accepted by the coupler. No sending to the coupler will be done from here
804	! (it is done in cpl_send_seaice_fields).
805	!
806	INCLUDE "dimensions.h"
807
808	! Input arguments
809	!*************************************************************************************
810	INTEGER, INTENT(IN) :: itime
811	INTEGER, INTENT(IN) :: knon
812	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
813	REAL, DIMENSION(klon), INTENT(IN) :: rriv_in
814	REAL, DIMENSION(klon), INTENT(IN) :: rcoa_in
815
816	! Local variables
817	!*************************************************************************************
818	REAL, DIMENSION(iim,jj_nb) :: rriv2D
819	REAL, DIMENSION(iim,jj_nb) :: rcoa2D
820
821	!*************************************************************************************
822	! Rearrange fields in 2D variables
823	! First initialize to zero to avoid unvalid points causing problems
824	!
825	!*************************************************************************************
826	rriv2D(:,:) = 0.0
827	rcoa2D(:,:) = 0.0
828	CALL gath2cpl(rriv_in, rriv2D, knon, knindex)
829	CALL gath2cpl(rcoa_in, rcoa2D, knon, knindex)
830
831	!*************************************************************************************
832	! Reset cumulated fields to zero in the beginning of a new coupling period
833	!
834	!*************************************************************************************
835	IF (MOD(itime, nexca) == 1) THEN
836	cpl_rriv2D(:,:) = 0.0
837	cpl_rcoa2D(:,:) = 0.0
838	ENDIF
839
840	!*************************************************************************************
841	! Cumulate : Following fields should be cumulated at each time-step
842	!
843	!*************************************************************************************
844	cpl_rriv2D(:,:) = cpl_rriv2D(:,:) + rriv2D(:,:) / FLOAT(nexca)
845	cpl_rcoa2D(:,:) = cpl_rcoa2D(:,:) + rcoa2D(:,:) / FLOAT(nexca)
846
847	END SUBROUTINE cpl_send_land_fields
848
849	!
850	!*************************************************************************************
851	!
852
853	SUBROUTINE cpl_send_landice_fields(itime, knon, knindex, rlic_in)
854	! This subroutine cumulates the field for melting ice for each time-step
855	! during a coupling period. This routine will not send to coupler. Sending
856	! will be done in cpl_send_seaice_fields.
857	!
858	INCLUDE "dimensions.h"
859
860	! Input varibales
861	!*************************************************************************************
862	INTEGER, INTENT(IN) :: itime
863	INTEGER, INTENT(IN) :: knon
864	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
865	REAL, DIMENSION(klon), INTENT(IN) :: rlic_in
866
867	! Local varibales
868	!*************************************************************************************
869	REAL, DIMENSION(iim,jj_nb) :: rlic2D
870
871	!*************************************************************************************
872	! Rearrange field in a 2D variable
873	! First initialize to zero to avoid unvalid points causing problems
874	!
875	!*************************************************************************************
876	rlic2D(:,:) = 0.0
877	CALL gath2cpl(rlic_in, rlic2D, knon, knindex)
878
879	!*************************************************************************************
880	! Reset field to zero in the beginning of a new coupling period
881	!
882	!*************************************************************************************
883	IF (MOD(itime, nexca) == 1) THEN
884	cpl_rlic2D(:,:) = 0.0
885	ENDIF
886
887	!*************************************************************************************
888	! Cumulate : Melting ice should be cumulated at each time-step
889	!
890	!*************************************************************************************
891	cpl_rlic2D(:,:) = cpl_rlic2D(:,:) + rlic2D(:,:) / FLOAT(nexca)
892
893	END SUBROUTINE cpl_send_landice_fields
894
895	!
896	!*************************************************************************************
897	!
898
899	SUBROUTINE cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat)
900	! This routine will send fields for all different surfaces to the coupler.
901	! This subroutine should be executed after calculations by the last surface(sea-ice),
902	! all calculations at the different surfaces have to be done before.
903	!
904	USE surface_data, ONLY : version_ocean
905	! Some includes
906	!*************************************************************************************
907	INCLUDE "indicesol.h"
908	INCLUDE "temps.h"
909	INCLUDE "dimensions.h"
910
911	! Input arguments
912	!*************************************************************************************
913	INTEGER, INTENT(IN) :: itime
914	REAL, INTENT(IN) :: dtime
915	REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
916	REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
917	LOGICAL, INTENT(IN) :: lafin
918
919	! Local variables
920	!*************************************************************************************
921	INTEGER :: error, sum_error, j
922	INTEGER :: itau_w
923	INTEGER :: il_time_secs
924	INTEGER, DIMENSION(iim*(jjm+1)) :: ndexct
925	REAL :: Up, Down
926	REAL, DIMENSION(iim, jj_nb) :: tmp_lon, tmp_lat
927	REAL, DIMENSION(iim, jj_nb, 4) :: pctsrf2D
928	REAL, DIMENSION(iim, jj_nb) :: deno
929	CHARACTER(len = 20) :: modname = 'cpl_send_all'
930	CHARACTER(len = 80) :: abort_message
931
932	! Variables with fields to coupler
933	REAL, DIMENSION(iim, jj_nb) :: tmp_taux
934	REAL, DIMENSION(iim, jj_nb) :: tmp_tauy
935	REAL, DIMENSION(iim, jj_nb) :: tmp_calv
936	! Table with all fields to send to coupler
937	REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2) :: tab_flds
938	#ifdef CPP_PARA
939	INCLUDE 'mpif.h'
940	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status
941	#endif
942
943	! End definitions
944	!*************************************************************************************
945
946
947
948	!*************************************************************************************
949	! All fields are stored in a table tab_flds(:,:,:)
950	! First store the fields which are already on the right format
951	!
952	!*************************************************************************************
953
954	tab_flds(:,:,7) = cpl_windsp2D(:,:)
955	tab_flds(:,:,8) = cpl_sols2D(:,:,2)
956	tab_flds(:,:,10) = cpl_nsol2D(:,:,2)
957	tab_flds(:,:,12) = cpl_fder2D(:,:,2)
958
959	IF (version_ocean=='nemo') THEN
960	tab_flds(:,:,18) = cpl_rriv2D(:,:) + cpl_rcoa2D(:,:)
961	ELSE IF (version_ocean=='opa8') THEN
962	tab_flds(:,:,9) = cpl_sols2D(:,:,1)
963	tab_flds(:,:,11) = cpl_nsol2D(:,:,1)
964
965	tab_flds(:,:,13) = cpl_evap2D(:,:,2)
966	tab_flds(:,:,14) = cpl_evap2D(:,:,1)
967	tab_flds(:,:,17) = cpl_rcoa2D(:,:)
968	tab_flds(:,:,18) = cpl_rriv2D(:,:)
969	ENDIF
970
971	!*************************************************************************************
972	! Transform the fraction of sub-surfaces from 1D to 2D array
973	!
974	!*************************************************************************************
975	pctsrf2D(:,:,:) = 0.
976	CALL gath2cpl(pctsrf(:,is_oce), pctsrf2D(:,:,is_oce), klon, unity)
977	CALL gath2cpl(pctsrf(:,is_sic), pctsrf2D(:,:,is_sic), klon, unity)
978	CALL gath2cpl(pctsrf(:,is_lic), pctsrf2D(:,:,is_lic), klon, unity)
979
980	!*************************************************************************************
981	! Calculate the average calving per latitude
982	! Store calving in tab_flds(:,:,19)
983	!
984	!*************************************************************************************
985	DO j = 1, jj_nb
986	tmp_calv(:,j) = DOT_PRODUCT (cpl_rlic2D(1:iim,j), &
987	pctsrf2D(1:iim,j,is_lic)) / REAL(iim)
988	ENDDO
989
990
991	IF (is_parallel) THEN
992	IF (.NOT. is_north_pole) THEN
993	#ifdef CPP_PARA
994	CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error)
995	CALL MPI_SEND(tmp_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,error)
996	#endif
997	ENDIF
998
999	IF (.NOT. is_south_pole) THEN
1000	#ifdef CPP_PARA
1001	CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error)
1002	CALL MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,error)
1003	#endif
1004	ENDIF
1005
1006	IF (.NOT. is_north_pole .AND. ii_begin /=1) THEN
1007	Up=Up+tmp_calv(iim,1)
1008	tmp_calv(:,1)=Up
1009	ENDIF
1010
1011	IF (.NOT. is_south_pole .AND. ii_end /= iim) THEN
1012	Down=Down+tmp_calv(1,jj_nb)
1013	tmp_calv(:,jj_nb)=Down
1014	ENDIF
1015	ENDIF
1016
1017
1018	IF (version_ocean=='nemo') THEN
1019	tab_flds(:,:,17) = tmp_calv(:,:)
1020	ELSE IF (version_ocean=='opa8') THEN
1021	tab_flds(:,:,19) = tmp_calv(:,:)
1022	ENDIF
1023
1024	!*************************************************************************************
1025	! Calculate total flux for snow, rain and wind with weighted addition using the
1026	! fractions of ocean and seaice.
1027	!
1028	!*************************************************************************************
1029	! fraction oce+seaice
1030	deno = pctsrf2D(:,:,is_oce) + pctsrf2D(:,:,is_sic)
1031
1032	IF (version_ocean=='nemo') THEN
1033
1034	tab_flds(:,:,9) = 0.0
1035	tab_flds(:,:,11) = 0.0
1036	tab_flds(:,:,13) = 0.0
1037	tab_flds(:,:,14) = 0.0
1038	tab_flds(:,:,15) = 0.0
1039	tmp_taux(:,:) = 0.0
1040	tmp_tauy(:,:) = 0.0
1041
1042	! For all valid grid cells containing some fraction of ocean or sea-ice
1043	WHERE ( deno(:,:) /= 0 )
1044	tmp_taux = cpl_taux2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + &
1045	cpl_taux2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1046	tmp_tauy = cpl_tauy2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + &
1047	cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1048	tab_flds(:,:,9) = cpl_sols2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + &
1049	cpl_sols2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1050	tab_flds(:,:,11) = cpl_nsol2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + &
1051	cpl_nsol2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1052	tab_flds(:,:,13) = cpl_rain2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + &
1053	cpl_rain2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1054	tab_flds(:,:,14) = cpl_snow2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + &
1055	cpl_snow2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1056	tab_flds(:,:,15) = cpl_evap2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + &
1057	cpl_evap2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1058	ENDWHERE
1059
1060	tab_flds(:,:,16) = cpl_evap2D(:,:,2)
1061
1062	ELSE IF (version_ocean=='opa8') THEN
1063	! Store fields for rain and snow in tab_flds(:,:,15) and tab_flds(:,:,16)
1064	tab_flds(:,:,15) = 0.0
1065	tab_flds(:,:,16) = 0.0
1066	tmp_taux(:,:) = 0.0
1067	tmp_tauy(:,:) = 0.0
1068
1069	! For all valid grid cells containing some fraction of ocean or sea-ice
1070	WHERE ( deno(:,:) /= 0 )
1071	tab_flds(:,:,15) = cpl_rain2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + &
1072	cpl_rain2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1073	tab_flds(:,:,16) = cpl_snow2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + &
1074	cpl_snow2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1075
1076	tmp_taux = cpl_taux2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + &
1077	cpl_taux2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1078	tmp_tauy = cpl_tauy2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + &
1079	cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1080	ENDWHERE
1081	ENDIF
1082
1083	!*************************************************************************************
1084	! Transform the wind components from local atmospheric 2D coordinates to geocentric
1085	! 3D coordinates.
1086	! Store the resulting wind components in tab_flds(:,:,1:6)
1087	!*************************************************************************************
1088
1089	! Transform the longitudes and latitudes on 2D arrays
1090	CALL Grid1DTo2D_mpi(rlon,tmp_lon)
1091	CALL Grid1DTo2D_mpi(rlat,tmp_lat)
1092
1093	IF (is_sequential) THEN
1094	IF (is_north_pole) tmp_lon(:,1) = tmp_lon(:,2)
1095	IF (is_south_pole) tmp_lon(:,jjm+1) = tmp_lon(:,jjm)
1096	ENDIF
1097
1098	! NetCDF output of the wind before transformation of coordinate system
1099	IF (is_sequential) THEN
1100	ndexct(:) = 0
1101	itau_w = itau_phy + itime
1102	CALL histwrite(nidct,'tauxe',itau_w,tmp_taux,iim*(jjm+1),ndexct)
1103	CALL histwrite(nidct,'tauyn',itau_w,tmp_tauy,iim*(jjm+1),ndexct)
1104	CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct)
1105	CALL histwrite(nidct,'tmp_lat',itau_w,tmp_lat,iim*(jjm+1),ndexct)
1106	ENDIF
1107
1108	! Transform the wind from local atmospheric 2D coordinates to geocentric
1109	! 3D coordinates
1110	CALL atm2geo (iim, jj_nb, tmp_taux, tmp_tauy, tmp_lon, tmp_lat, &
1111	tab_flds(:,:,1), tab_flds(:,:,2), tab_flds(:,:,3) )
1112
1113	tab_flds(:,:,4) = tab_flds(:,:,1)
1114	tab_flds(:,:,5) = tab_flds(:,:,2)
1115	tab_flds(:,:,6) = tab_flds(:,:,3)
1116
1117	!*************************************************************************************
1118	! NetCDF output of all fields just before sending to coupler.
1119	!
1120	!*************************************************************************************
1121	IF (is_sequential) THEN
1122	CALL histwrite(nidct,cl_writ(8), itau_w,tab_flds(:,:,8), iim*(jjm+1),ndexct)
1123	CALL histwrite(nidct,cl_writ(9), itau_w,tab_flds(:,:,9), iim*(jjm+1),ndexct)
1124	CALL histwrite(nidct,cl_writ(10),itau_w,tab_flds(:,:,10),iim*(jjm+1),ndexct)
1125	CALL histwrite(nidct,cl_writ(11),itau_w,tab_flds(:,:,11),iim*(jjm+1),ndexct)
1126	CALL histwrite(nidct,cl_writ(12),itau_w,tab_flds(:,:,12),iim*(jjm+1),ndexct)
1127	CALL histwrite(nidct,cl_writ(13),itau_w,tab_flds(:,:,13),iim*(jjm+1),ndexct)
1128	CALL histwrite(nidct,cl_writ(14),itau_w,tab_flds(:,:,14),iim*(jjm+1),ndexct)
1129	CALL histwrite(nidct,cl_writ(15),itau_w,tab_flds(:,:,15),iim*(jjm+1),ndexct)
1130	CALL histwrite(nidct,cl_writ(16),itau_w,tab_flds(:,:,16),iim*(jjm+1),ndexct)
1131	CALL histwrite(nidct,cl_writ(17),itau_w,tab_flds(:,:,17),iim*(jjm+1),ndexct)
1132	CALL histwrite(nidct,cl_writ(18),itau_w,tab_flds(:,:,18),iim*(jjm+1),ndexct)
1133	CALL histwrite(nidct,cl_writ(19),itau_w,tab_flds(:,:,19),iim*(jjm+1),ndexct)
1134	CALL histwrite(nidct,cl_writ(1), itau_w,tab_flds(:,:,1), iim*(jjm+1),ndexct)
1135	CALL histwrite(nidct,cl_writ(2), itau_w,tab_flds(:,:,2), iim*(jjm+1),ndexct)
1136	CALL histwrite(nidct,cl_writ(3), itau_w,tab_flds(:,:,3), iim*(jjm+1),ndexct)
1137	CALL histwrite(nidct,cl_writ(4), itau_w,tab_flds(:,:,4), iim*(jjm+1),ndexct)
1138	CALL histwrite(nidct,cl_writ(5), itau_w,tab_flds(:,:,5), iim*(jjm+1),ndexct)
1139	CALL histwrite(nidct,cl_writ(6), itau_w,tab_flds(:,:,6), iim*(jjm+1),ndexct)
1140	CALL histwrite(nidct,cl_writ(7), itau_w,tab_flds(:,:,7), iim*(jjm+1),ndexct)
1141	CALL histsync(nidct)
1142	ENDIF
1143
1144
1145	!*************************************************************************************
1146	! Send the table of all fields
1147	!
1148	!*************************************************************************************
1149	#ifdef CPP_COUPLE
1150	il_time_secs=(itime-1)*dtime
1151	CALL intocpl(il_time_secs, lafin, tab_flds(:,:,:))
1152	#endif
1153
1154	!*************************************************************************************
1155	! Finish with some dellocate
1156	!
1157	!*************************************************************************************
1158	sum_error=0
1159	DEALLOCATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D, cpl_snow2D, stat=error )
1160	sum_error = sum_error + error
1161	DEALLOCATE(cpl_evap2D, cpl_tsol2D, cpl_fder2D, cpl_albe2D, stat=error )
1162	sum_error = sum_error + error
1163	DEALLOCATE(cpl_taux2D, cpl_tauy2D, cpl_windsp2D, stat=error )
1164	sum_error = sum_error + error
1165	IF (sum_error /= 0) THEN
1166	abort_message='Pb in deallocation of cpl_xxxx2D coupling variables'
1167	CALL abort_gcm(modname,abort_message,1)
1168	ENDIF
1169
1170	END SUBROUTINE cpl_send_all
1171	!
1172	!*************************************************************************************
1173	!
1174	SUBROUTINE cpl2gath(champ_in, champ_out, knon, knindex)
1175	! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
1176	! au coupleur.
1177	!
1178	!
1179	! input:
1180	! champ_in champ sur la grille gathere
1181	! knon nombre de points dans le domaine a traiter
1182	! knindex index des points de la surface a traiter
1183	!
1184	! output:
1185	! champ_out champ sur la grille 2D
1186	!
1187	INCLUDE "dimensions.h"
1188
1189	! Input
1190	INTEGER, INTENT(IN) :: knon
1191	REAL, DIMENSION(iim,jj_nb), INTENT(IN) :: champ_in
1192	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
1193
1194	! Output
1195	REAL, DIMENSION(klon), INTENT(OUT) :: champ_out
1196
1197	! Local
1198	INTEGER :: i, ig
1199	REAL, DIMENSION(klon) :: tamp
1200
1201	!*************************************************************************************
1202	!
1203	! Transform from 2 dimensions (iim,jj_nb) to 1 dimension (klon)
1204	CALL Grid2Dto1D_mpi(champ_in,tamp)
1205
1206	! Compress from klon to knon
1207	DO i = 1, knon
1208	ig = knindex(i)
1209	champ_out(i) = tamp(ig)
1210	ENDDO
1211
1212	END SUBROUTINE cpl2gath
1213	!
1214	!*************************************************************************************
1215	!
1216	SUBROUTINE gath2cpl(champ_in, champ_out, knon, knindex)
1217	! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
1218	! au coupleur.
1219	!
1220	! input:
1221	! champ_in champ sur la grille gathere
1222	! knon nombre de points dans le domaine a traiter
1223	! knindex index des points de la surface a traiter
1224	!
1225	! output:
1226	! champ_out champ sur la grille 2D
1227	!
1228	INCLUDE "dimensions.h"
1229
1230	! Input arguments
1231	!*************************************************************************************
1232	INTEGER, INTENT(IN) :: knon
1233	REAL, DIMENSION(klon), INTENT(IN) :: champ_in
1234	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
1235
1236	! Output arguments
1237	!*************************************************************************************
1238	REAL, DIMENSION(iim,jj_nb), INTENT(OUT) :: champ_out
1239
1240	! Local variables
1241	!*************************************************************************************
1242	INTEGER :: i, ig
1243	REAL, DIMENSION(klon) :: tamp
1244
1245	!*************************************************************************************
1246
1247	! Decompress from knon to klon
1248	tamp = 0.
1249	DO i = 1, knon
1250	ig = knindex(i)
1251	tamp(ig) = champ_in(i)
1252	ENDDO
1253
1254	! Transform from 1 dimension (klon) to 2 dimensions (iim,jj_nb)
1255	CALL Grid1Dto2D_mpi(tamp,champ_out)
1256
1257	IF (is_north_pole) champ_out(:,1)=tamp(1)
1258	IF (is_south_pole) champ_out(:,jj_nb)=tamp(klon)
1259
1260	END SUBROUTINE gath2cpl
1261	!
1262	!*************************************************************************************
1263	!
1264	END MODULE cpl_mod
1265

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

Download in other formats:

Original Format