Context Navigation

cpl_mod.F90 @ 989

Last change on this file since 989 was 987, checked in by Laurent Fairhead, 17 years ago
Du nettoyage sur le parallelisme, inclusion de nouvelles interfaces pour OPA9 et ORCHIDEE YM LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 52.8 KB

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

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

Download in other formats:

Original Format