source: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cpl_mod.F90 @ 5426

Last change on this file since 5426 was 1454, checked in by Laurent Fairhead, 14 years ago

Merge of LMDZ5V1.0-dev branch r1453 into LMDZ5 trunk r1434


Fusion entre la version r1453 de la branche de développement LMDZ5V1.0-dev
et le tronc LMDZ5 (r1434)

  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 55.2 KB
Line 
1!
2MODULE 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
96CONTAINS
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
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
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!
1402END MODULE cpl_mod
1403
Note: See TracBrowser for help on using the repository browser.