Context Navigation

cpl_mod.F90 @ 785

Last change on this file since 785 was 782, checked in by Laurent Fairhead, 18 years ago
Adaptation du code a la nouvelle interface avec les surface de Josefine LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 49.7 KB

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

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

Download in other formats:

Original Format