Context Navigation

cpl_mod.F90 @ 989

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

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

Download in other formats:

Original Format