Context Navigation

cpl_mod.F90 @ 3809

Last change on this file since 3809 was 3809, checked in by ymipsl, 10 years ago
Add LMDZ in aquaplanet configuration YM
Property svn:executable set to ``*
File size: 55.3 KB

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

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

Download in other formats:

Original Format