source: LMDZ4/branches/LMDZ4_V3_patches/libf/phylmd/cpl_mod.F90 @ 1075

Last change on this file since 1075 was 1075, checked in by jghattas, 16 years ago

Modification des champs de couplage pour NEMO.

Arnaud Caubel

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