Context Navigation

cpl_mod.F90 @ 3958

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

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

Download in other formats:

Original Format