source: LMDZ4/branches/LMDZ4-dev/libf/phylmd/cpl_mod.F90 @ 1125

Last change on this file since 1125 was 1125, checked in by jghattas, 15 years ago

Ajout de la possiblite de couplage de vitesse de glace de mer, uniquement avec NEMO et cpl_current=true.

JG

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