source: LMDZ5/branches/LMDZ6_rc0/libf/phylmd/cpl_mod.F90 @ 3069

Last change on this file since 3069 was 2160, checked in by Laurent Fairhead, 10 years ago

Merged trunk changes -r2070:2158 into testing branch. Compilation problems introduced by revision r2155 have been corrected by hand

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