Context Navigation

cpl_mod.F90 @ 996

Last change on this file since 996 was 996, checked in by lsce, 16 years ago

Modifications liées au calcul des nouveau sous-fractions
Nettoyage de ocean slab : il reste uniquement la version avec glace de mer forcé
Nouveaux variables pour distiguer la version et type d'ocean : type_ocean=force/slab/couple, version_ocean=opa8/nemo pour couplé ou version_ocean=sicOBS pour slab

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

File size: 51.2 KB

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

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

Download in other formats:

Original Format