source: LMDZ4/trunk/libf/phylmd/cpl_mod.F90 @ 1687

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

Merged LMDZ4V5.0-dev branch changes r1292:r1399 to trunk.

Validation:
Validation consisted in compiling the HEAD revision of the trunk,
LMDZ4V5.0-dev branch and the merged sources and running different
configurations on local and SX8 machines comparing results.

Local machine: bench configuration, 32x24x11, gfortran

  • IPSLCM5A configuration (comparison between trunk and merged sources):
    • numerical convergence on dynamical fields over 3 days
    • start files are equivalent (except for RN and PB fields)
    • daily history files equivalent
  • MH07 configuration, new physics package (comparison between LMDZ4V5.0-dev branch and merged sources):
    • numerical convergence on dynamical fields over 3 days
    • start files are equivalent (except for RN and PB fields)
    • daily history files equivalent

SX8 machine (brodie), 96x95x39 on 4 processors:

  • IPSLCM5A configuration:
    • start files are equivalent (except for RN and PB fields)
    • monthly history files equivalent
  • MH07 configuration:
    • start files are equivalent (except for RN and PB fields)
    • monthly history files equivalent

Changes to the makegcm and create_make_gcm scripts to take into account
main programs in F90 files


Fusion de la branche LMDZ4V5.0-dev (r1292:r1399) au tronc principal

Validation:
La validation a consisté à compiler la HEAD de le trunk et de la banche
LMDZ4V5.0-dev et les sources fusionnées et de faire tourner le modéle selon
différentes configurations en local et sur SX8 et de comparer les résultats

En local: 32x24x11, config bench/gfortran

  • pour une config IPSLCM5A (comparaison tronc/fusion):
    • convergence numérique sur les champs dynamiques après 3 jours
    • restart et restartphy égaux (à part sur RN et Pb)
    • fichiers histoire égaux
  • pour une config nlle physique (MH07) (comparaison LMDZ4v5.0-dev/fusion):
    • convergence numérique sur les champs dynamiques après 3 jours
    • restart et restartphy égaux
    • fichiers histoire équivalents

Sur brodie, 96x95x39 sur 4 proc:

  • pour une config IPSLCM5A:
    • restart et restartphy égaux (à part sur RN et PB)
    • pas de différence dans les fichiers histmth.nc
  • pour une config MH07
    • restart et restartphy égaux (à part sur RN et PB)
    • pas de différence dans les fichiers histmth.nc

Changement sur makegcm et create_make-gcm pour pouvoir prendre en compte des
programmes principaux en *F90

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