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