Context Navigation

cpl_mod.F90 @ 1

Last change on this file since 1 was 1, checked in by emillour, 14 years ago
Import initial LMDZ5
File size: 54.8 KB

Rev	Line
[1]	1	!
	2	MODULE 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
	96	CONTAINS
	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	!
	1391	END MODULE cpl_mod
	1392

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format