Context Navigation

cpl_mod.F90 @ 808

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

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

Download in other formats:

Original Format