Context Navigation

cpl_mod.F90 @ 1267

Last change on this file since 1267 was 1227, checked in by jghattas, 15 years ago

Inclusion d'un premier version du cycle de carbon dans LMDZ. Attention

!! Il s'agit d'un version ou les nouveaux cles cycle_carbon_tr et
cycle_carbon_cpl ne sont pas teste. Avec les ancinenes parametres le
modele donne les memes resultats qu'avant. L'interface avec ORCHIDEE n'a
pas encore etait modifie.

physiq.F, phys_cal_mod.F90 : ajout d'un nouveau module qui contient qq parametres pour le calendrier et le pas de temps acutelle de la physiq. Ce module pourrait etre elargie plus tard / LF + JG

infotrac.F90 : les noms du traceurs peut prendre un nom plus long (15 caracteres) dans traceur.def

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

File size: 53.7 KB

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

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

Download in other formats:

Original Format