source: LMDZ4/trunk/libf/phy_IPCC_AR4/cpl_mod.F90 @ 965

Last change on this file since 965 was 868, checked in by Laurent Fairhead, 17 years ago

Preparation du remplacement de la physique utilisee pour l'exercice IPCC_AR4
par la version de la physique avec thermique. On garde le repertoire phylmd
pour un petit moment pour que les utilisateurs ne soient pas trop perdus ...
phy_IPCC_AR4 = phylmd
LF
  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 49.2 KB
RevLine 
[868]1!
2! $Header$
3!
4MODULE cpl_mod
5!
6! This module excahanges and transforms all fields that should be recieved or sent to
7! coupler. The transformation of the fields are done from the grid 1D-array in phylmd
8! to the regular 2D grid accepted by the coupler. Cumulation of the fields for each
9! timestep is done in here.
10!
11! Each type of surface that recevie fields from the coupler have a subroutine named
12! cpl_receive_XXX_fields and each surface that have fields to be sent to the coupler
13! have a subroutine named cpl_send_XXX_fields.
14!
15!*************************************************************************************
16
17! Use statements
18!*************************************************************************************
19  USE dimphy, ONLY : klon
20  USE mod_phys_lmdz_para
21  USE ioipsl
22  USE iophy
23
24! The module oasis is always used. Without the cpp key CPP_COUPLE only the parameters
25! in the module are compiled and not the subroutines.
26  USE oasis
27  USE write_field_phy
28 
29! Global attributes
30!*************************************************************************************
31  IMPLICIT NONE
32  PRIVATE
33
34  ! All subroutine are public except cpl_send_all and cpl_receive_all
35  PUBLIC :: cpl_init, cpl_receive_ocean_fields, cpl_receive_seaice_fields, &
36       cpl_send_ocean_fields, cpl_send_seaice_fields, cpl_send_land_fields, &
37       cpl_send_landice_fields, gath2cpl
38 
39
40! Declaration of module variables
41!*************************************************************************************
42! variable for coupling period
43  INTEGER, SAVE                             :: nexca
44  !$OMP THREADPRIVATE(nexca)
45
46! variables for cumulating fields during a coupling periode :
47  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_sols, cpl_nsol, cpl_rain
48  !$OMP THREADPRIVATE(cpl_sols,cpl_nsol,cpl_rain)
49  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_snow, cpl_evap, cpl_tsol
50  !$OMP THREADPRIVATE(cpl_snow,cpl_evap,cpl_tsol)
51  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_fder, cpl_albe, cpl_taux
52  !$OMP THREADPRIVATE(cpl_fder,cpl_albe,cpl_taux)
53  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_windsp
54  !$OMP THREADPRIVATE(cpl_windsp)
55  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_tauy
56  !$OMP THREADPRIVATE(cpl_tauy)
57  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_rriv2D, cpl_rcoa2D, cpl_rlic2D
58  !$OMP THREADPRIVATE(cpl_rriv2D,cpl_rcoa2D,cpl_rlic2D)
59
60! variables read from coupler :
61  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sst     ! sea surface temperature
62  !$OMP THREADPRIVATE(read_sst)
63  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sit     ! sea ice temperature
64  !$OMP THREADPRIVATE(read_sit)
65  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sic     ! sea ice fraction
66  !$OMP THREADPRIVATE(read_sic)
67  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_alb_sic ! albedo at sea ice
68  !$OMP THREADPRIVATE(read_alb_sic)
69 
70! fraction for different surface, saved during whole coupling period
71  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: pctsrf_sav   
72  !$OMP THREADPRIVATE(pctsrf_sav)
73  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: unity
74  !$OMP THREADPRIVATE(unity)
75  INTEGER, SAVE                             :: nidct, nidcs
76  !$OMP THREADPRIVATE(nidct,nidcs)
77
78! variables to be sent to the coupler
79  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_sols2D, cpl_nsol2D, cpl_rain2D
80  !$OMP THREADPRIVATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D)
81  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_snow2D, cpl_evap2D, cpl_tsol2D
82  !$OMP THREADPRIVATE(cpl_snow2D, cpl_evap2D, cpl_tsol2D)
83  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_fder2D, cpl_albe2D
84  !$OMP THREADPRIVATE(cpl_fder2D, cpl_albe2D)
85  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_taux2D, cpl_tauy2D
86  !$OMP THREADPRIVATE(cpl_taux2D, cpl_tauy2D)
87  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_windsp2D
88  !$OMP THREADPRIVATE(cpl_windsp2D)
89 
90
91CONTAINS
92!
93!************************************************************************************
94!
95  SUBROUTINE cpl_init(dtime, rlon, rlat)
96
97    INCLUDE "dimensions.h"
98    INCLUDE "indicesol.h"
99    INCLUDE "control.h"
100    INCLUDE "temps.h"
101    INCLUDE "iniprint.h"
102
103! Input arguments
104!*************************************************************************************
105    REAL, INTENT(IN)                  :: dtime
106    REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
107
108! Local variables
109!*************************************************************************************
110    INTEGER                           :: error, sum_error, ig, i
111    INTEGER                           :: jf, nhoridct
112    INTEGER                           :: nhoridcs
113    INTEGER                           :: idtime
114    INTEGER                           :: idayref
115    INTEGER                           :: npas ! only for OASIS2
116    REAL                              :: zjulian
117    REAL, DIMENSION(iim,jjm+1)        :: zx_lon, zx_lat
118    CHARACTER(len = 20)               :: modname = 'cpl_init'
119    CHARACTER(len = 80)               :: abort_message
120    CHARACTER(len=80)                 :: clintocplnam, clfromcplnam
121
122!*************************************************************************************
123! Calculate coupling period
124!
125!*************************************************************************************
126     
127    npas = itaufin/ iphysiq
128    nexca = 86400 / dtime
129    WRITE(lunout,*)' ##### Ocean couple #####'
130    WRITE(lunout,*)' Valeurs des pas de temps'
131    WRITE(lunout,*)' npas = ', npas
132    WRITE(lunout,*)' nexca = ', nexca
133   
134!*************************************************************************************
135! Allocate variables
136!
137!*************************************************************************************
138    error = 0
139    sum_error = 0
140
141    ALLOCATE(unity(klon), stat = error)
142    sum_error = sum_error + error
143    ALLOCATE(pctsrf_sav(klon,nbsrf), stat = error)
144    sum_error = sum_error + error
145    ALLOCATE(cpl_sols(klon,2), stat = error)
146    sum_error = sum_error + error
147    ALLOCATE(cpl_nsol(klon,2), stat = error)
148    sum_error = sum_error + error
149    ALLOCATE(cpl_rain(klon,2), stat = error)
150    sum_error = sum_error + error
151    ALLOCATE(cpl_snow(klon,2), stat = error)
152    sum_error = sum_error + error
153    ALLOCATE(cpl_evap(klon,2), stat = error)
154    sum_error = sum_error + error
155    ALLOCATE(cpl_tsol(klon,2), stat = error)
156    sum_error = sum_error + error
157    ALLOCATE(cpl_fder(klon,2), stat = error)
158    sum_error = sum_error + error
159    ALLOCATE(cpl_albe(klon,2), stat = error)
160    sum_error = sum_error + error
161    ALLOCATE(cpl_taux(klon,2), stat = error)
162    sum_error = sum_error + error
163    ALLOCATE(cpl_windsp(klon,2), stat = error)
164    sum_error = sum_error + error
165    ALLOCATE(cpl_tauy(klon,2), stat = error)
166    sum_error = sum_error + error
167    ALLOCATE(cpl_rriv2D(iim,jj_nb), stat=error)
168    sum_error = sum_error + error
169    ALLOCATE(cpl_rcoa2D(iim,jj_nb), stat=error)
170    sum_error = sum_error + error
171    ALLOCATE(cpl_rlic2D(iim,jj_nb), stat=error)
172    sum_error = sum_error + error
173    ALLOCATE(read_sst(iim, jj_nb), stat = error)
174    sum_error = sum_error + error
175    ALLOCATE(read_sic(iim, jj_nb), stat = error)
176    sum_error = sum_error + error
177    ALLOCATE(read_sit(iim, jj_nb), stat = error)
178    sum_error = sum_error + error
179    ALLOCATE(read_alb_sic(iim, jj_nb), stat = error)
180    sum_error = sum_error + error
181
182    IF (sum_error /= 0) THEN
183       abort_message='Pb allocation variables couplees'
184       CALL abort_gcm(modname,abort_message,1)
185    ENDIF
186!*************************************************************************************
187! Initialize the allocated varaibles
188!
189!*************************************************************************************
190    DO ig = 1, klon
191       unity(ig) = ig
192    ENDDO
193    pctsrf_sav = 0.
194
195    cpl_sols = 0.   ; cpl_nsol = 0.  ; cpl_rain = 0.   ; cpl_snow = 0.
196    cpl_evap = 0.   ; cpl_tsol = 0.  ; cpl_fder = 0.   ; cpl_albe = 0.
197    cpl_taux = 0.   ; cpl_tauy = 0.  ; cpl_rriv2D = 0. ; cpl_rcoa2D = 0.
198    cpl_rlic2D = 0. ; cpl_windsp = 0.
199
200!*************************************************************************************
201! Initialize coupling
202!
203!*************************************************************************************
204    idtime = INT(dtime)
205#ifdef CPP_COUPLE
206    CALL inicma
207#endif
208
209!*************************************************************************************
210! initialize NetCDF output
211!
212!*************************************************************************************
213    IF (is_sequential) THEN
214       idayref = day_ini
215       CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
216       CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
217       DO i = 1, iim
218          zx_lon(i,1) = rlon(i+1)
219          zx_lon(i,jjm+1) = rlon(i+1)
220       ENDDO
221       CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
222       clintocplnam="cpl_atm_tauflx"
223       CALL histbeg(clintocplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),&
224            1,iim,1,jjm+1, itau_phy,zjulian,dtime,nhoridct,nidct)
225! no vertical axis
226       CALL histdef(nidct, 'tauxe','tauxe', &
227            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
228       CALL histdef(nidct, 'tauyn','tauyn', &
229            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
230       CALL histdef(nidct, 'tmp_lon','tmp_lon', &
231            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
232       CALL histdef(nidct, 'tmp_lat','tmp_lat', &
233            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
234       DO jf=1,jpflda2o1 + jpflda2o2
235          CALL histdef(nidct, cl_writ(jf),cl_writ(jf), &
236               "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
237       END DO
238       CALL histend(nidct)
239       CALL histsync(nidct)
240       
241       clfromcplnam="cpl_atm_sst"
242       CALL histbeg(clfromcplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, &
243            0,zjulian,dtime,nhoridcs,nidcs)
244! no vertical axis
245       DO jf=1,jpfldo2a
246          CALL histdef(nidcs, cl_read(jf),cl_read(jf), &
247               "-",iim, jjm+1, nhoridcs, 1, 1, 1, -99, 32, "inst", dtime,dtime)
248       END DO
249       CALL histend(nidcs)
250       CALL histsync(nidcs)
251
252    ENDIF    ! is_sequential
253   
254  END SUBROUTINE cpl_init
255 
256!
257!*************************************************************************************
258!
259
260  SUBROUTINE cpl_receive_all(itime, dtime, pctsrf)
261! This subroutine reads from coupler for both ocean and seaice
262! 4 fields : read_sst, read_sic, read_sit and read_alb_sic.
263
264    INCLUDE "indicesol.h"
265    INCLUDE "temps.h"
266    INCLUDE "iniprint.h"
267    INCLUDE "YOMCST.h"
268    INCLUDE "dimensions.h"
269
270! Input arguments
271!************************************************************************************
272    INTEGER, INTENT(IN)                     :: itime
273    REAL, INTENT(IN)                        :: dtime
274    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
275
276! Local variables
277!************************************************************************************
278    INTEGER                                 :: j, ig, il_time_secs
279    INTEGER                                 :: itau_w
280    INTEGER, DIMENSION(iim*(jjm+1))         :: ndexcs
281    CHARACTER(len = 20)                     :: modname = 'cpl_receive_all'
282    CHARACTER(len = 80)                     :: abort_message
283    REAL, DIMENSION(klon)                   :: read_sic1D
284    REAL, DIMENSION(iim,jj_nb,jpfldo2a)  :: tab_read_flds
285    REAL, DIMENSION(iim,jj_nb)           :: read_sic
286
287!*************************************************************************************
288! Start calculation
289! Get fields from coupler
290!
291!*************************************************************************************
292
293#ifdef CPP_COUPLE
294    il_time_secs=(itime-1)*dtime
295    CALL fromcpl(il_time_secs, tab_read_flds)
296#endif
297   
298! NetCDF output of received fields
299    IF (is_sequential) THEN
300       ndexcs(:) = 0
301       itau_w = itau_phy + itime
302       DO ig = 1, jpfldo2a
303          CALL histwrite(nidcs,cl_read(ig),itau_w,tab_read_flds(:,:,ig),iim*(jjm+1),ndexcs)
304       END DO
305    ENDIF
306
307! Save each field in a 2D array.
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! Some includes
905!*************************************************************************************
906    INCLUDE "indicesol.h"
907    INCLUDE "temps.h"
908    INCLUDE "dimensions.h"
909   
910! Input arguments
911!*************************************************************************************
912    INTEGER, INTENT(IN)                                  :: itime
913    REAL, INTENT(IN)                                     :: dtime
914    REAL, DIMENSION(klon), INTENT(IN)                    :: rlon, rlat
915    REAL, DIMENSION(klon,nbsrf), INTENT(IN)              :: pctsrf
916    LOGICAL, INTENT(IN)                                  :: lafin
917   
918! Local variables
919!*************************************************************************************
920    INTEGER                                              :: error, sum_error, j
921    INTEGER                                              :: itau_w
922    INTEGER                                              :: il_time_secs
923    INTEGER, DIMENSION(iim*(jjm+1))                      :: ndexct
924    REAL                                                 :: Up, Down
925    REAL, DIMENSION(iim, jj_nb)                          :: tmp_lon, tmp_lat
926    REAL, DIMENSION(iim, jj_nb, 4)                       :: pctsrf2D
927    REAL, DIMENSION(iim, jj_nb)                          :: deno
928    CHARACTER(len = 20)                                  :: modname = 'cpl_send_all'
929    CHARACTER(len = 80)                                  :: abort_message
930   
931! Variables with fields to coupler
932    REAL, DIMENSION(iim, jj_nb)                          :: tmp_taux
933    REAL, DIMENSION(iim, jj_nb)                          :: tmp_tauy
934    REAL, DIMENSION(iim, jj_nb)                          :: tmp_calv
935! Table with all fields to send to coupler
936    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2)     :: tab_flds
937#ifdef CPP_PARA
938    INCLUDE 'mpif.h'
939    INTEGER, DIMENSION(MPI_STATUS_SIZE)                  :: status
940#endif
941
942! End definitions
943!*************************************************************************************
944   
945
946
947!*************************************************************************************
948! All fields are stored in a table tab_flds(:,:,:)
949! First store the fields 7 to 18 which are already on the right format
950!
951!*************************************************************************************
952    tab_flds(:,:,7)  = cpl_windsp2D(:,:)
953    tab_flds(:,:,8)  = cpl_sols2D(:,:,2)
954    tab_flds(:,:,9)  = cpl_sols2D(:,:,1)
955    tab_flds(:,:,10) = cpl_nsol2D(:,:,2)
956    tab_flds(:,:,11) = cpl_nsol2D(:,:,1)
957    tab_flds(:,:,12) = cpl_fder2D(:,:,2)
958    tab_flds(:,:,13) = cpl_evap2D(:,:,2)
959    tab_flds(:,:,14) = cpl_evap2D(:,:,1)
960    tab_flds(:,:,17) = cpl_rcoa2D(:,:)
961    tab_flds(:,:,18) = cpl_rriv2D(:,:)
962   
963!*************************************************************************************
964! Transform the fraction of sub-surfaces from 1D to 2D array
965!
966!*************************************************************************************
967    pctsrf2D(:,:,:) = 0.
968    CALL gath2cpl(pctsrf(:,is_oce), pctsrf2D(:,:,is_oce), klon, unity)
969    CALL gath2cpl(pctsrf(:,is_sic), pctsrf2D(:,:,is_sic), klon, unity)
970    CALL gath2cpl(pctsrf(:,is_lic), pctsrf2D(:,:,is_lic), klon, unity)
971
972!*************************************************************************************
973! Calculate the average calving per latitude
974! Store calving in tab_flds(:,:,19)
975!
976!*************************************************************************************     
977    DO j = 1, jj_nb
978       tmp_calv(:,j) = DOT_PRODUCT (cpl_rlic2D(1:iim,j), &
979            pctsrf2D(1:iim,j,is_lic)) / REAL(iim)
980    ENDDO
981   
982   
983    IF (is_parallel) THEN
984       IF (.NOT. is_north_pole) THEN
985#ifdef CPP_PARA
986          CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error)
987          CALL MPI_SEND(tmp_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,error)
988#endif
989       ENDIF
990       
991       IF (.NOT. is_south_pole) THEN
992#ifdef CPP_PARA
993          CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error)
994          CALL MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,error)
995#endif
996       ENDIF
997       
998       IF (.NOT. is_north_pole .AND. ii_begin /=1) THEN
999          Up=Up+tmp_calv(iim,1)
1000          tmp_calv(:,1)=Up
1001       ENDIF
1002       
1003       IF (.NOT. is_south_pole .AND. ii_end /= iim) THEN
1004          Down=Down+tmp_calv(1,jj_nb)
1005          tmp_calv(:,jj_nb)=Down         
1006       ENDIF
1007    ENDIF
1008     
1009
1010    tab_flds(:,:,19) = tmp_calv(:,:)
1011
1012!*************************************************************************************
1013! Calculate total flux for snow, rain and wind with weighted addition using the
1014! fractions of ocean and seaice.
1015!
1016! Store the fields for rain and snow directly in tab_flds(:,:,15) and
1017! tab_flds(:,:,16) respectively.
1018!
1019!*************************************************************************************   
1020    tab_flds(:,:,15) = 0.0
1021    tab_flds(:,:,16) = 0.0
1022    tmp_taux(:,:)    = 0.0
1023    tmp_tauy(:,:)    = 0.0
1024   
1025
1026    ! fraction oce+seaice
1027    deno =  pctsrf2D(:,:,is_oce) + pctsrf2D(:,:,is_sic)
1028    ! For all valid grid cells containing some fraction of ocean or sea-ice
1029    WHERE ( deno(:,:) /= 0 )
1030       tab_flds(:,:,15) = cpl_rain2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
1031            cpl_rain2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1032       tab_flds(:,:,16) = cpl_snow2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
1033            cpl_snow2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1034       
1035       tmp_taux = cpl_taux2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
1036            cpl_taux2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1037       tmp_tauy = cpl_tauy2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
1038            cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
1039    ENDWHERE
1040
1041!*************************************************************************************
1042! Transform the wind components from local atmospheric 2D coordinates to geocentric
1043! 3D coordinates.
1044! Store the resulting wind components in tab_flds(:,:,1:6)
1045!*************************************************************************************
1046
1047! Transform the longitudes and latitudes on 2D arrays
1048    CALL Grid1DTo2D_mpi(rlon,tmp_lon)
1049    CALL Grid1DTo2D_mpi(rlat,tmp_lat)
1050   
1051    IF (is_sequential) THEN
1052       IF (is_north_pole) tmp_lon(:,1)     = tmp_lon(:,2)
1053       IF (is_south_pole) tmp_lon(:,jjm+1) = tmp_lon(:,jjm)
1054    ENDIF
1055     
1056! NetCDF output of the wind before transformation of coordinate system
1057    IF (is_sequential) THEN
1058       ndexct(:) = 0
1059       itau_w = itau_phy + itime
1060       CALL histwrite(nidct,'tauxe',itau_w,tmp_taux,iim*(jjm+1),ndexct)
1061       CALL histwrite(nidct,'tauyn',itau_w,tmp_tauy,iim*(jjm+1),ndexct)
1062       CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct)
1063       CALL histwrite(nidct,'tmp_lat',itau_w,tmp_lat,iim*(jjm+1),ndexct)
1064    ENDIF
1065
1066! Transform the wind from local atmospheric 2D coordinates to geocentric
1067! 3D coordinates
1068    CALL atm2geo (iim, jj_nb, tmp_taux, tmp_tauy, tmp_lon, tmp_lat, &
1069         tab_flds(:,:,1), tab_flds(:,:,2), tab_flds(:,:,3) )
1070   
1071    tab_flds(:,:,4)  = tab_flds(:,:,1)
1072    tab_flds(:,:,5)  = tab_flds(:,:,2)
1073    tab_flds(:,:,6)  = tab_flds(:,:,3)
1074
1075!*************************************************************************************
1076! NetCDF output of all fields just before sending to coupler.
1077!
1078!*************************************************************************************
1079    IF (is_sequential) THEN
1080       CALL histwrite(nidct,cl_writ(8), itau_w,tab_flds(:,:,8), iim*(jjm+1),ndexct)
1081       CALL histwrite(nidct,cl_writ(9), itau_w,tab_flds(:,:,9), iim*(jjm+1),ndexct)
1082       CALL histwrite(nidct,cl_writ(10),itau_w,tab_flds(:,:,10),iim*(jjm+1),ndexct)
1083       CALL histwrite(nidct,cl_writ(11),itau_w,tab_flds(:,:,11),iim*(jjm+1),ndexct)
1084       CALL histwrite(nidct,cl_writ(12),itau_w,tab_flds(:,:,12),iim*(jjm+1),ndexct)
1085       CALL histwrite(nidct,cl_writ(13),itau_w,tab_flds(:,:,13),iim*(jjm+1),ndexct)
1086       CALL histwrite(nidct,cl_writ(14),itau_w,tab_flds(:,:,14),iim*(jjm+1),ndexct)
1087       CALL histwrite(nidct,cl_writ(15),itau_w,tab_flds(:,:,15),iim*(jjm+1),ndexct)
1088       CALL histwrite(nidct,cl_writ(16),itau_w,tab_flds(:,:,16),iim*(jjm+1),ndexct)
1089       CALL histwrite(nidct,cl_writ(17),itau_w,tab_flds(:,:,17),iim*(jjm+1),ndexct)
1090       CALL histwrite(nidct,cl_writ(18),itau_w,tab_flds(:,:,18),iim*(jjm+1),ndexct)
1091       CALL histwrite(nidct,cl_writ(19),itau_w,tab_flds(:,:,19),iim*(jjm+1),ndexct)
1092       CALL histwrite(nidct,cl_writ(1), itau_w,tab_flds(:,:,1), iim*(jjm+1),ndexct)
1093       CALL histwrite(nidct,cl_writ(2), itau_w,tab_flds(:,:,2), iim*(jjm+1),ndexct)
1094       CALL histwrite(nidct,cl_writ(3), itau_w,tab_flds(:,:,3), iim*(jjm+1),ndexct)
1095       CALL histwrite(nidct,cl_writ(4), itau_w,tab_flds(:,:,4), iim*(jjm+1),ndexct)
1096       CALL histwrite(nidct,cl_writ(5), itau_w,tab_flds(:,:,5), iim*(jjm+1),ndexct)
1097       CALL histwrite(nidct,cl_writ(6), itau_w,tab_flds(:,:,6), iim*(jjm+1),ndexct)
1098       CALL histwrite(nidct,cl_writ(7), itau_w,tab_flds(:,:,7), iim*(jjm+1),ndexct)
1099       CALL histsync(nidct)
1100    ENDIF
1101
1102
1103!*************************************************************************************
1104! Send the table of all fields
1105!
1106!*************************************************************************************
1107#ifdef CPP_COUPLE
1108    il_time_secs=(itime-1)*dtime
1109    CALL intocpl(il_time_secs, lafin, tab_flds(:,:,:))
1110#endif
1111
1112!*************************************************************************************
1113! Finish with some dellocate
1114!
1115!************************************************************************************* 
1116    sum_error=0
1117    DEALLOCATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D, cpl_snow2D, stat=error )
1118    sum_error = sum_error + error
1119    DEALLOCATE(cpl_evap2D, cpl_tsol2D, cpl_fder2D, cpl_albe2D, stat=error )
1120    sum_error = sum_error + error
1121    DEALLOCATE(cpl_taux2D, cpl_tauy2D, cpl_windsp2D, stat=error )
1122    sum_error = sum_error + error
1123    IF (sum_error /= 0) THEN
1124       abort_message='Pb in deallocation of cpl_xxxx2D coupling variables'
1125       CALL abort_gcm(modname,abort_message,1)
1126    ENDIF
1127   
1128  END SUBROUTINE cpl_send_all
1129!
1130!*************************************************************************************
1131!
1132  SUBROUTINE cpl2gath(champ_in, champ_out, knon, knindex)
1133! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
1134! au coupleur.
1135!
1136!
1137! input:         
1138!   champ_in     champ sur la grille gathere       
1139!   knon         nombre de points dans le domaine a traiter
1140!   knindex      index des points de la surface a traiter
1141!
1142! output:
1143!   champ_out    champ sur la grille 2D
1144!
1145    INCLUDE "dimensions.h"
1146
1147! Input
1148    INTEGER, INTENT(IN)                       :: knon
1149    REAL, DIMENSION(iim,jj_nb), INTENT(IN)    :: champ_in
1150    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
1151
1152! Output
1153    REAL, DIMENSION(klon), INTENT(OUT)        :: champ_out
1154
1155! Local
1156    INTEGER                                   :: i, ig
1157    REAL, DIMENSION(klon)                     :: tamp
1158
1159!*************************************************************************************
1160!
1161! Transform from 2 dimensions (iim,jj_nb) to 1 dimension (klon)
1162    CALL Grid2Dto1D_mpi(champ_in,tamp)
1163
1164! Compress from klon to knon
1165    DO i = 1, knon
1166       ig = knindex(i)
1167       champ_out(i) = tamp(ig)
1168    ENDDO
1169
1170  END SUBROUTINE cpl2gath
1171!
1172!*************************************************************************************
1173!
1174  SUBROUTINE gath2cpl(champ_in, champ_out, knon, knindex)
1175! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
1176! au coupleur.
1177!
1178! input:         
1179!   champ_in     champ sur la grille gathere       
1180!   knon         nombre de points dans le domaine a traiter
1181!   knindex      index des points de la surface a traiter
1182!
1183! output:
1184!   champ_out    champ sur la grille 2D
1185!
1186    INCLUDE "dimensions.h"
1187   
1188! Input arguments
1189!*************************************************************************************
1190    INTEGER, INTENT(IN)                    :: knon
1191    REAL, DIMENSION(klon), INTENT(IN)      :: champ_in
1192    INTEGER, DIMENSION(klon), INTENT(IN)   :: knindex
1193
1194! Output arguments
1195!*************************************************************************************
1196    REAL, DIMENSION(iim,jj_nb), INTENT(OUT) :: champ_out
1197
1198! Local variables
1199!*************************************************************************************
1200    INTEGER                                :: i, ig
1201    REAL, DIMENSION(klon)                  :: tamp
1202
1203!*************************************************************************************
1204
1205! Decompress from knon to klon
1206    tamp = 0.
1207    DO i = 1, knon
1208       ig = knindex(i)
1209       tamp(ig) = champ_in(i)
1210    ENDDO
1211
1212! Transform from 1 dimension (klon) to 2 dimensions (iim,jj_nb)
1213    CALL Grid1Dto2D_mpi(tamp,champ_out)
1214   
1215    IF (is_north_pole) champ_out(:,1)=tamp(1)
1216    IF (is_south_pole) champ_out(:,jj_nb)=tamp(klon)
1217   
1218  END SUBROUTINE gath2cpl
1219!
1220!*************************************************************************************
1221!
1222END MODULE cpl_mod
1223
Note: See TracBrowser for help on using the repository browser.