Context Navigation

cpl_mod.F90 @ 2344

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

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

Download in other formats:

Original Format