Context Navigation

cpl_mod.F90 @ 1189

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

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

Download in other formats:

Original Format