Context Navigation

cpl_mod.F90 @ 1085

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

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

Download in other formats:

Original Format