Context Navigation

cpl_mod.F90 @ 1125

Last change on this file since 1125 was 1125, checked in by jghattas, 15 years ago
Ajout de la possiblite de couplage de vitesse de glace de mer, uniquement avec NEMO et cpl_current=true. JG
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 52.2 KB

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

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

Download in other formats:

Original Format