Context Navigation

cpl_mod.F90 @ 2060

Last change on this file since 2060 was 1299, checked in by Laurent Fairhead, 15 years ago

Nettoyage general pour se rapprocher des normes et éviter des erreurs a la
compilation:

tous les FLOAT() sont remplacés par des REAL()
tous les STOP dans phylmd sont remplacés par des appels à abort_gcm
le common control défini dans le fichier control.h est remplacé par le module control_mod pour éviter des messages sur l'alignement des variables dans les déclarations
des $Header$ remplacés par des $Id$ pour svn

Quelques remplacements à faire ont pu m'échapper

General cleanup of the code to try and adhere to norms and to prevent some
compilation errors:

all FLOAT() instructions have been replaced by REAL() instructions
all STOP instructions in phylmd have been replaced by calls to abort_gcm
the common block control defined in the control.h file has been replaced by the control_mod to prevent compilation warnings on the alignement of declared variables
$Header$ replaced by $Id$ for svn

Some changes which should have been made might have escaped me

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

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

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

Download in other formats:

Original Format