Context Navigation

cpl_mod.F90 @ 1085

Last change on this file since 1085 was 1067, checked in by Laurent Fairhead, 16 years ago

Modifications lie au premier niveau du modele pour la diffusion turbulent

du vent.

Preparation pour un couplage des courrant oceaniques.

Property svn:eol-style set to native
Property svn:executable set to *
Property svn:keywords set to Author Date Id Revision

File size: 52.7 KB

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

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

Download in other formats:

Original Format