Context Navigation

surf_land_orchidee_noopenmp_mod.F90 @ 2602

Last change on this file since 2602 was 2572, checked in by jghattas, 8 years ago
Corected bug introduced in rev [2240] : guistiness was added in the subroutine surf_land_orchidee in the default module but the old module were forgotten.
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory
File size: 27.2 KB

Line
1	!
2	! $Header$
3	!
4	MODULE surf_land_orchidee_noopenmp_mod
5	!
6	! This module is compiled only if CPP key ORCHIDEE_NOOPENMP is defined.
7	! This module should be used with ORCHIDEE sequentiel or parallele MPI version
8	! (not MPI-OpenMP mixte) until revision 1077 in the ORCHIDEE trunk.
9
10	#ifdef ORCHIDEE_NOOPENMP
11	!
12	! This module controles the interface towards the model ORCHIDEE
13	!
14	! Subroutines in this module : surf_land_orchidee
15	! Init_orchidee_index
16	! Get_orchidee_communicator
17	! Init_neighbours
18	USE dimphy
19	#ifdef CPP_VEGET
20	USE intersurf ! module d'ORCHIDEE
21	#endif
22	USE cpl_mod, ONLY : cpl_send_land_fields
23	USE surface_data, ONLY : type_ocean
24	USE geometry_mod, ONLY : dx, dy
25	USE mod_grid_phy_lmdz
26	USE mod_phys_lmdz_para
27
28	IMPLICIT NONE
29
30	PRIVATE
31	PUBLIC :: surf_land_orchidee
32
33	CONTAINS
34	!
35	!****************************************************************************************
36	!
37	SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, &
38	knindex, rlon, rlat, yrmu0, pctsrf, &
39	debut, lafin, &
40	plev, u1_lay, v1_lay, gustiness, temp_air, spechum, epot_air, ccanopy, &
41	tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
42	precip_rain, precip_snow, lwdown, swnet, swdown, &
43	ps, q2m, t2m, &
44	evap, fluxsens, fluxlat, &
45	tsol_rad, tsurf_new, alb1_new, alb2_new, &
46	emis_new, z0_new, z0h_new, qsurf)
47	!
48	! Cette routine sert d'interface entre le modele atmospherique et le
49	! modele de sol continental. Appel a sechiba
50	!
51	! L. Fairhead 02/2000
52	!
53	! input:
54	! itime numero du pas de temps
55	! dtime pas de temps de la physique (en s)
56	! nisurf index de la surface a traiter (1 = sol continental)
57	! knon nombre de points de la surface a traiter
58	! knindex index des points de la surface a traiter
59	! rlon longitudes de la grille entiere
60	! rlat latitudes de la grille entiere
61	! pctsrf tableau des fractions de surface de chaque maille
62	! debut logical: 1er appel a la physique (lire les restart)
63	! lafin logical: dernier appel a la physique (ecrire les restart)
64	! (si false calcul simplifie des fluxs sur les continents)
65	! plev hauteur de la premiere couche (Pa)
66	! u1_lay vitesse u 1ere couche
67	! v1_lay vitesse v 1ere couche
68	! temp_air temperature de l'air 1ere couche
69	! spechum humidite specifique 1ere couche
70	! epot_air temp pot de l'air
71	! ccanopy concentration CO2 canopee, correspond au co2_send de
72	! carbon_cycle_mod ou valeur constant co2_ppm
73	! tq_cdrag cdrag
74	! petAcoef coeff. A de la resolution de la CL pour t
75	! peqAcoef coeff. A de la resolution de la CL pour q
76	! petBcoef coeff. B de la resolution de la CL pour t
77	! peqBcoef coeff. B de la resolution de la CL pour q
78	! precip_rain precipitation liquide
79	! precip_snow precipitation solide
80	! lwdown flux IR descendant a la surface
81	! swnet flux solaire net
82	! swdown flux solaire entrant a la surface
83	! ps pression au sol
84	! radsol rayonnement net aus sol (LW + SW)
85	!
86	!
87	! output:
88	! evap evaporation totale
89	! fluxsens flux de chaleur sensible
90	! fluxlat flux de chaleur latente
91	! tsol_rad
92	! tsurf_new temperature au sol
93	! alb1_new albedo in visible SW interval
94	! alb2_new albedo in near IR interval
95	! emis_new emissivite
96	! z0_new surface roughness
97	! z0h_new surface roughness, it is the same as z0_new
98	! qsurf air moisture at surface
99	!
100	USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, fco2_land_inst, fco2_lu_inst
101	USE indice_sol_mod
102	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
103	USE print_control_mod, ONLY: lunout
104	#ifdef CPP_VEGET
105	USE time_phylmdz_mod, ONLY: itau_phy
106	#endif
107	IMPLICIT NONE
108
109	INCLUDE "YOMCST.h"
110
111	!
112	! Parametres d'entree
113	!****************************************************************************************
114	INTEGER, INTENT(IN) :: itime
115	REAL, INTENT(IN) :: dtime
116	REAL, INTENT(IN) :: date0
117	INTEGER, INTENT(IN) :: knon
118	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
119	LOGICAL, INTENT(IN) :: debut, lafin
120	REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
121	REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
122	REAL, DIMENSION(klon), INTENT(IN) :: yrmu0
123	REAL, DIMENSION(klon), INTENT(IN) :: plev
124	REAL, DIMENSION(klon), INTENT(IN) :: u1_lay, v1_lay, gustiness
125	REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum
126	REAL, DIMENSION(klon), INTENT(IN) :: epot_air, ccanopy
127	REAL, DIMENSION(klon), INTENT(IN) :: tq_cdrag
128	REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef
129	REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef
130	REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow
131	REAL, DIMENSION(klon), INTENT(IN) :: lwdown, swnet, swdown, ps
132	REAL, DIMENSION(klon), INTENT(IN) :: q2m, t2m
133
134	! Parametres de sortie
135	!****************************************************************************************
136	REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat, qsurf
137	REAL, DIMENSION(klon), INTENT(OUT) :: tsol_rad, tsurf_new
138	REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new
139	REAL, DIMENSION(klon), INTENT(OUT) :: emis_new, z0_new, z0h_new
140
141	! Local
142	!****************************************************************************************
143	INTEGER :: ij, jj, igrid, ireal, index
144	INTEGER :: error
145	INTEGER, SAVE :: nb_fields_cpl ! number of fields for the climate-carbon coupling (between ATM and ORCHIDEE).
146	REAL, SAVE, ALLOCATABLE, DIMENSION(:,:) :: fields_cpl ! Fluxes for the climate-carbon coupling
147	REAL, DIMENSION(klon) :: swdown_vrai
148	CHARACTER (len = 20) :: modname = 'surf_land_orchidee'
149	CHARACTER (len = 80) :: abort_message
150	LOGICAL,SAVE :: check = .FALSE.
151	!$OMP THREADPRIVATE(check)
152
153	! type de couplage dans sechiba
154	! character (len=10) :: coupling = 'implicit'
155	! drapeaux controlant les appels dans SECHIBA
156	! type(control_type), save :: control_in
157	! Preserved albedo
158	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: albedo_keep, zlev
159	!$OMP THREADPRIVATE(albedo_keep,zlev)
160	! coordonnees geographiques
161	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: lalo
162	!$OMP THREADPRIVATE(lalo)
163	! pts voisins
164	INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours
165	!$OMP THREADPRIVATE(neighbours)
166	! fractions continents
167	REAL,ALLOCATABLE, DIMENSION(:), SAVE :: contfrac
168	!$OMP THREADPRIVATE(contfrac)
169	! resolution de la grille
170	REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: resolution
171	!$OMP THREADPRIVATE(resolution)
172
173	REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: lon_scat, lat_scat
174	!$OMP THREADPRIVATE(lon_scat,lat_scat)
175
176	LOGICAL, SAVE :: lrestart_read = .TRUE.
177	!$OMP THREADPRIVATE(lrestart_read)
178	LOGICAL, SAVE :: lrestart_write = .FALSE.
179	!$OMP THREADPRIVATE(lrestart_write)
180
181	REAL, DIMENSION(knon,2) :: albedo_out
182	!$OMP THREADPRIVATE(albedo_out)
183
184	! Pb de nomenclature
185	REAL, DIMENSION(klon) :: petA_orc, peqA_orc
186	REAL, DIMENSION(klon) :: petB_orc, peqB_orc
187	! Pb de correspondances de grilles
188	INTEGER, DIMENSION(:), SAVE, ALLOCATABLE :: ig, jg
189	!$OMP THREADPRIVATE(ig,jg)
190	INTEGER :: indi, indj
191	INTEGER, SAVE, ALLOCATABLE,DIMENSION(:) :: ktindex
192	!$OMP THREADPRIVATE(ktindex)
193
194	! Essai cdrag
195	REAL, DIMENSION(klon) :: cdrag
196	INTEGER,SAVE :: offset
197	!$OMP THREADPRIVATE(offset)
198
199	REAL, DIMENSION(klon_glo) :: rlon_g,rlat_g
200	INTEGER, SAVE :: orch_comm
201	!$OMP THREADPRIVATE(orch_comm)
202
203	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: coastalflow
204	!$OMP THREADPRIVATE(coastalflow)
205	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: riverflow
206	!$OMP THREADPRIVATE(riverflow)
207	!
208	! Fin definition
209	!****************************************************************************************
210	#ifdef CPP_VEGET
211
212	IF (check) WRITE(lunout,*)'Entree ', modname
213
214	! Initialisation
215
216	IF (debut) THEN
217	! Test de coherence
218	#ifndef ORCH_NEW
219	! Compilation avec orchidee nouvelle version necessaire avec carbon_cycle_cpl=y
220	IF (carbon_cycle_cpl) THEN
221	abort_message='You must define preprossing key ORCH_NEW when running carbon_cycle_cpl=y'
222	CALL abort_physic(modname,abort_message,1)
223	END IF
224	#endif
225	ALLOCATE(ktindex(knon))
226	IF ( .NOT. ALLOCATED(albedo_keep)) THEN
227	ALLOCATE(albedo_keep(klon))
228	ALLOCATE(zlev(knon))
229	ENDIF
230	! Pb de correspondances de grilles
231	ALLOCATE(ig(klon))
232	ALLOCATE(jg(klon))
233	ig(1) = 1
234	jg(1) = 1
235	indi = 0
236	indj = 2
237	DO igrid = 2, klon - 1
238	indi = indi + 1
239	IF ( indi > nbp_lon) THEN
240	indi = 1
241	indj = indj + 1
242	ENDIF
243	ig(igrid) = indi
244	jg(igrid) = indj
245	ENDDO
246	ig(klon) = 1
247	jg(klon) = nbp_lat
248
249	IF ((.NOT. ALLOCATED(lalo))) THEN
250	ALLOCATE(lalo(knon,2), stat = error)
251	IF (error /= 0) THEN
252	abort_message='Pb allocation lalo'
253	CALL abort_physic(modname,abort_message,1)
254	ENDIF
255	ENDIF
256	IF ((.NOT. ALLOCATED(lon_scat))) THEN
257	ALLOCATE(lon_scat(nbp_lon,nbp_lat), stat = error)
258	IF (error /= 0) THEN
259	abort_message='Pb allocation lon_scat'
260	CALL abort_physic(modname,abort_message,1)
261	ENDIF
262	ENDIF
263	IF ((.NOT. ALLOCATED(lat_scat))) THEN
264	ALLOCATE(lat_scat(nbp_lon,nbp_lat), stat = error)
265	IF (error /= 0) THEN
266	abort_message='Pb allocation lat_scat'
267	CALL abort_physic(modname,abort_message,1)
268	ENDIF
269	ENDIF
270	lon_scat = 0.
271	lat_scat = 0.
272	DO igrid = 1, knon
273	index = knindex(igrid)
274	lalo(igrid,2) = rlon(index)
275	lalo(igrid,1) = rlat(index)
276	ENDDO
277
278
279
280	CALL Gather(rlon,rlon_g)
281	CALL Gather(rlat,rlat_g)
282
283	IF (is_mpi_root) THEN
284	index = 1
285	DO jj = 2, nbp_lat-1
286	DO ij = 1, nbp_lon
287	index = index + 1
288	lon_scat(ij,jj) = rlon_g(index)
289	lat_scat(ij,jj) = rlat_g(index)
290	ENDDO
291	ENDDO
292	lon_scat(:,1) = lon_scat(:,2)
293	lat_scat(:,1) = rlat_g(1)
294	lon_scat(:,nbp_lat) = lon_scat(:,2)
295	lat_scat(:,nbp_lat) = rlat_g(klon_glo)
296	ENDIF
297
298	CALL bcast(lon_scat)
299	CALL bcast(lat_scat)
300
301	!
302	! Allouer et initialiser le tableau des voisins et des fraction de continents
303	!
304	IF ( (.NOT.ALLOCATED(neighbours))) THEN
305	ALLOCATE(neighbours(knon,8), stat = error)
306	IF (error /= 0) THEN
307	abort_message='Pb allocation neighbours'
308	CALL abort_physic(modname,abort_message,1)
309	ENDIF
310	ENDIF
311	neighbours = -1.
312	IF (( .NOT. ALLOCATED(contfrac))) THEN
313	ALLOCATE(contfrac(knon), stat = error)
314	IF (error /= 0) THEN
315	abort_message='Pb allocation contfrac'
316	CALL abort_physic(modname,abort_message,1)
317	ENDIF
318	ENDIF
319
320	DO igrid = 1, knon
321	ireal = knindex(igrid)
322	contfrac(igrid) = pctsrf(ireal,is_ter)
323	ENDDO
324
325
326	CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter))
327
328	!
329	! Allocation et calcul resolutions
330	IF ( (.NOT.ALLOCATED(resolution))) THEN
331	ALLOCATE(resolution(knon,2), stat = error)
332	IF (error /= 0) THEN
333	abort_message='Pb allocation resolution'
334	CALL abort_physic(modname,abort_message,1)
335	ENDIF
336	ENDIF
337	DO igrid = 1, knon
338	ij = knindex(igrid)
339	resolution(igrid,1) = dx(ij)
340	resolution(igrid,2) = dy(ij)
341	ENDDO
342
343	ALLOCATE(coastalflow(klon), stat = error)
344	IF (error /= 0) THEN
345	abort_message='Pb allocation coastalflow'
346	CALL abort_physic(modname,abort_message,1)
347	ENDIF
348
349	ALLOCATE(riverflow(klon), stat = error)
350	IF (error /= 0) THEN
351	abort_message='Pb allocation riverflow'
352	CALL abort_physic(modname,abort_message,1)
353	ENDIF
354
355	!
356	! Allocate variables needed for carbon_cycle_mod
357	IF ( carbon_cycle_cpl ) THEN
358	nb_fields_cpl=2
359	ELSE
360	nb_fields_cpl=1
361	END IF
362
363
364	IF (carbon_cycle_cpl) THEN
365	ALLOCATE(fco2_land_inst(klon),stat=error)
366	IF (error /= 0) CALL abort_physic(modname,'Pb in allocation fco2_land_inst',1)
367
368	ALLOCATE(fco2_lu_inst(klon),stat=error)
369	IF(error /=0) CALL abort_physic(modname,'Pb in allocation fco2_lu_inst',1)
370	END IF
371
372	ALLOCATE(fields_cpl(klon,nb_fields_cpl), stat = error)
373	IF (error /= 0) CALL abort_physic(modname,'Pb in allocation fields_cpl',1)
374
375	ENDIF ! (fin debut)
376
377	!
378	! Appel a la routine sols continentaux
379	!
380	IF (lafin) lrestart_write = .TRUE.
381	IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write
382
383	petA_orc(1:knon) = petBcoef(1:knon) * dtime
384	petB_orc(1:knon) = petAcoef(1:knon)
385	peqA_orc(1:knon) = peqBcoef(1:knon) * dtime
386	peqB_orc(1:knon) = peqAcoef(1:knon)
387
388	cdrag = 0.
389	cdrag(1:knon) = tq_cdrag(1:knon)
390
391	! zlev(1:knon) = (100.plev(1:knon))/((ps(1:knon)/287.05temp_air(1:knon))*9.80665)
392	zlev(1:knon) = (100.plev(1:knon))/((ps(1:knon)/RDtemp_air(1:knon))*RG)
393
394
395	! PF et PASB
396	! where(cdrag > 0.01)
397	! cdrag = 0.01
398	! endwhere
399	! write(,)'Cdrag = ',minval(cdrag),maxval(cdrag)
400
401	!
402	! Init Orchidee
403	!
404	! if (pole_nord) then
405	! offset=0
406	! ktindex(:)=ktindex(:)+nbp_lon-1
407	! else
408	! offset = klon_mpi_begin-1+nbp_lon-1
409	! ktindex(:)=ktindex(:)+MOD(offset,nbp_lon)
410	! offset=offset-MOD(offset,nbp_lon)
411	! endif
412
413	IF (debut) THEN
414	CALL Get_orchidee_communicator(knon,orch_comm)
415	IF (knon /=0) THEN
416	CALL Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex)
417
418	#ifndef CPP_MPI
419	! Interface for ORCHIDEE compiled in sequential mode(without preprocessing flag CPP_MPI)
420	CALL intersurf_main (itime+itau_phy-1, nbp_lon, nbp_lat, knon, ktindex, dtime, &
421	lrestart_read, lrestart_write, lalo, &
422	contfrac, neighbours, resolution, date0, &
423	zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
424	cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
425	precip_rain, precip_snow, lwdown, swnet, swdown, ps, &
426	evap, fluxsens, fluxlat, coastalflow, riverflow, &
427	tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
428	lon_scat, lat_scat, q2m, t2m &
429	#ifdef ORCH_NEW
430	, nb_fields_cpl, fields_cpl)
431	#else
432	)
433	#endif
434
435	#else
436	! Interface for ORCHIDEE version 1.9 or later(1.9.2, 1.9.3, 1.9.4, 1.9.5) compiled in parallel mode(with preprocessing flag CPP_MPI)
437	CALL intersurf_main (itime+itau_phy-1, nbp_lon, nbp_lat, offset, knon, ktindex, &
438	orch_comm, dtime, lrestart_read, lrestart_write, lalo, &
439	contfrac, neighbours, resolution, date0, &
440	zlev, u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
441	cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
442	precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown(1:knon), ps(1:knon), &
443	evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
444	tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
445	lon_scat, lat_scat, q2m, t2m &
446	#ifdef ORCH_NEW
447	, nb_fields_cpl, fields_cpl(1:knon,:))
448	#else
449	)
450	#endif
451	#endif
452
453	ENDIF
454
455	albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
456
457	ENDIF
458
459	! swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon))
460	swdown_vrai(1:knon) = swdown(1:knon)
461
462	IF (knon /=0) THEN
463	#ifndef CPP_MPI
464	! Interface for ORCHIDEE compiled in sequential mode(without preprocessing flag CPP_MPI)
465	CALL intersurf_main (itime+itau_phy, nbp_lon, nbp_lat, knon, ktindex, dtime, &
466	lrestart_read, lrestart_write, lalo, &
467	contfrac, neighbours, resolution, date0, &
468	zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
469	cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
470	precip_rain, precip_snow, lwdown, swnet, swdown_vrai, ps, &
471	evap, fluxsens, fluxlat, coastalflow, riverflow, &
472	tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
473	lon_scat, lat_scat, q2m, t2m &
474	#ifdef ORCH_NEW
475	, nb_fields_cpl, fields_cpl)
476	#else
477	)
478	#endif
479	#else
480	! Interface for ORCHIDEE version 1.9 or later compiled in parallel mode(with preprocessing flag CPP_MPI)
481	CALL intersurf_main (itime+itau_phy, nbp_lon, nbp_lat,offset, knon, ktindex, &
482	orch_comm,dtime, lrestart_read, lrestart_write, lalo, &
483	contfrac, neighbours, resolution, date0, &
484	zlev, u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
485	cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
486	precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), &
487	evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
488	tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
489	lon_scat, lat_scat, q2m, t2m &
490	#ifdef ORCH_NEW
491	, nb_fields_cpl, fields_cpl(1:knon,:))
492	#else
493	)
494	#endif
495	#endif
496	ENDIF
497
498	albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
499
500	! ORCHIDEE only gives one value for z0_new. Copy it into z0h_new.
501	z0h_new(:)=z0_new(:)
502
503	!* Send to coupler
504	!
505	IF (type_ocean=='couple') THEN
506	CALL cpl_send_land_fields(itime, knon, knindex, &
507	riverflow, coastalflow)
508	ENDIF
509
510	alb1_new(1:knon) = albedo_out(1:knon,1)
511	alb2_new(1:knon) = albedo_out(1:knon,2)
512
513	! Convention orchidee: positif vers le haut
514	fluxsens(1:knon) = -1. * fluxsens(1:knon)
515	fluxlat(1:knon) = -1. * fluxlat(1:knon)
516
517	! evap = -1. * evap
518
519	IF (debut) lrestart_read = .FALSE.
520
521	! Decompress variables for the module carbon_cycle_mod
522	IF (carbon_cycle_cpl) THEN
523	fco2_land_inst(:)=0.
524	fco2_lu_inst(:)=0.
525
526	DO igrid = 1, knon
527	ireal = knindex(igrid)
528	fco2_land_inst(ireal) = fields_cpl(igrid,1)
529	fco2_lu_inst(ireal) = fields_cpl(igrid,2)
530	END DO
531	END IF
532
533	#endif
534	END SUBROUTINE surf_land_orchidee
535	!
536	!****************************************************************************************
537	!
538	SUBROUTINE Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex)
539
540	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
541
542	#ifdef CPP_MPI
543	INCLUDE 'mpif.h'
544	#endif
545
546
547	! Input arguments
548	!****************************************************************************************
549	INTEGER, INTENT(IN) :: knon
550	INTEGER, INTENT(IN) :: orch_comm
551	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
552
553	! Output arguments
554	!****************************************************************************************
555	INTEGER, INTENT(OUT) :: offset
556	INTEGER, DIMENSION(knon), INTENT(OUT) :: ktindex
557
558	! Local varables
559	!****************************************************************************************
560	#ifdef CPP_MPI
561	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status
562	#endif
563
564	INTEGER :: MyLastPoint
565	INTEGER :: LastPoint
566	INTEGER :: mpi_rank_orch
567	INTEGER :: mpi_size_orch
568	INTEGER :: ierr
569	!
570	! End definition
571	!****************************************************************************************
572
573	MyLastPoint=klon_mpi_begin-1+knindex(knon)+nbp_lon-1
574
575	IF (is_parallel) THEN
576	#ifdef CPP_MPI
577	CALL MPI_COMM_SIZE(orch_comm,mpi_size_orch,ierr)
578	CALL MPI_COMM_RANK(orch_comm,mpi_rank_orch,ierr)
579	#endif
580	ELSE
581	mpi_rank_orch=0
582	mpi_size_orch=1
583	ENDIF
584
585	IF (is_parallel) THEN
586	IF (mpi_rank_orch /= 0) THEN
587	#ifdef CPP_MPI
588	CALL MPI_RECV(LastPoint,1,MPI_INTEGER,mpi_rank_orch-1,1234,orch_comm,status,ierr)
589	#endif
590	ENDIF
591
592	IF (mpi_rank_orch /= mpi_size_orch-1) THEN
593	#ifdef CPP_MPI
594	CALL MPI_SEND(MyLastPoint,1,MPI_INTEGER,mpi_rank_orch+1,1234,orch_comm,ierr)
595	#endif
596	ENDIF
597	ENDIF
598
599	IF (mpi_rank_orch == 0) THEN
600	offset=0
601	ELSE
602	offset=LastPoint-MOD(LastPoint,nbp_lon)
603	ENDIF
604
605	ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin+nbp_lon-1)-offset-1
606
607
608	END SUBROUTINE Init_orchidee_index
609	!
610	!****************************************************************************************
611	!
612	SUBROUTINE Get_orchidee_communicator(knon,orch_comm)
613
614	#ifdef CPP_MPI
615	INCLUDE 'mpif.h'
616	#endif
617
618
619	INTEGER,INTENT(IN) :: knon
620	INTEGER,INTENT(OUT) :: orch_comm
621
622	INTEGER :: color
623	INTEGER :: ierr
624	!
625	! End definition
626	!****************************************************************************************
627
628	IF (knon==0) THEN
629	color = 0
630	ELSE
631	color = 1
632	ENDIF
633
634	#ifdef CPP_MPI
635	CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr)
636	#endif
637
638	END SUBROUTINE Get_orchidee_communicator
639	!
640	!****************************************************************************************
641	!
642	SUBROUTINE Init_neighbours(knon,neighbours,ktindex,pctsrf)
643
644	USE indice_sol_mod
645	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
646
647	#ifdef CPP_MPI
648	INCLUDE 'mpif.h'
649	#endif
650
651	! Input arguments
652	!****************************************************************************************
653	INTEGER, INTENT(IN) :: knon
654	INTEGER, DIMENSION(klon), INTENT(IN) :: ktindex
655	REAL, DIMENSION(klon), INTENT(IN) :: pctsrf
656
657	! Output arguments
658	!****************************************************************************************
659	INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours
660
661	! Local variables
662	!****************************************************************************************
663	INTEGER :: knon_g
664	INTEGER :: i, igrid, jj, ij, iglob
665	INTEGER :: ierr, ireal, index
666	INTEGER :: var_tmp
667	INTEGER, DIMENSION(0:mpi_size-1) :: knon_nb
668	INTEGER, DIMENSION(0:mpi_size-1) :: displs
669	INTEGER, DIMENSION(8,3) :: off_ini
670	INTEGER, DIMENSION(8) :: offset
671	INTEGER, DIMENSION(knon) :: ktindex_p
672	INTEGER, DIMENSION(nbp_lon,nbp_lat) :: correspond
673	INTEGER, ALLOCATABLE, DIMENSION(:) :: ktindex_g
674	INTEGER, ALLOCATABLE, DIMENSION(:,:) :: neighbours_g
675	REAL, DIMENSION(klon_glo) :: pctsrf_g
676
677	!
678	! End definition
679	!****************************************************************************************
680
681	IF (is_sequential) THEN
682	knon_nb(:)=knon
683	ELSE
684
685	#ifdef CPP_MPI
686	CALL MPI_GATHER(knon,1,MPI_INTEGER,knon_nb,1,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
687	#endif
688
689	ENDIF
690
691	IF (is_mpi_root) THEN
692	knon_g=SUM(knon_nb(:))
693	ALLOCATE(ktindex_g(knon_g))
694	ALLOCATE(neighbours_g(knon_g,8))
695	neighbours_g(:,:)=-1
696	displs(0)=0
697	DO i=1,mpi_size-1
698	displs(i)=displs(i-1)+knon_nb(i-1)
699	ENDDO
700	ELSE
701	ALLOCATE(ktindex_g(1))
702	ALLOCATE(neighbours_g(1,8))
703	ENDIF
704
705	ktindex_p(1:knon)=ktindex(1:knon)+klon_mpi_begin-1+nbp_lon-1
706
707	IF (is_sequential) THEN
708	ktindex_g(:)=ktindex_p(:)
709	ELSE
710
711	#ifdef CPP_MPI
712	CALL MPI_GATHERV(ktindex_p,knon,MPI_INTEGER,ktindex_g,knon_nb,&
713	displs,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
714	#endif
715
716	ENDIF
717
718	CALL Gather(pctsrf,pctsrf_g)
719
720	IF (is_mpi_root) THEN
721	! Initialisation des offset
722	!
723	! offset bord ouest
724	off_ini(1,1) = - nbp_lon ; off_ini(2,1) = - nbp_lon + 1; off_ini(3,1) = 1
725	off_ini(4,1) = nbp_lon + 1; off_ini(5,1) = nbp_lon ; off_ini(6,1) = 2 * nbp_lon - 1
726	off_ini(7,1) = nbp_lon -1 ; off_ini(8,1) = - 1
727	! offset point normal
728	off_ini(1,2) = - nbp_lon ; off_ini(2,2) = - nbp_lon + 1; off_ini(3,2) = 1
729	off_ini(4,2) = nbp_lon + 1; off_ini(5,2) = nbp_lon ; off_ini(6,2) = nbp_lon - 1
730	off_ini(7,2) = -1 ; off_ini(8,2) = - nbp_lon - 1
731	! offset bord est
732	off_ini(1,3) = - nbp_lon; off_ini(2,3) = - 2 * nbp_lon + 1; off_ini(3,3) = - nbp_lon + 1
733	off_ini(4,3) = 1 ; off_ini(5,3) = nbp_lon ; off_ini(6,3) = nbp_lon - 1
734	off_ini(7,3) = -1 ; off_ini(8,3) = - nbp_lon - 1
735	!
736	!
737	! Attention aux poles
738	!
739	DO igrid = 1, knon_g
740	index = ktindex_g(igrid)
741	jj = INT((index - 1)/nbp_lon) + 1
742	ij = index - (jj - 1) * nbp_lon
743	correspond(ij,jj) = igrid
744	ENDDO
745
746	DO igrid = 1, knon_g
747	iglob = ktindex_g(igrid)
748	IF (MOD(iglob, nbp_lon) == 1) THEN
749	offset = off_ini(:,1)
750	ELSE IF(MOD(iglob, nbp_lon) == 0) THEN
751	offset = off_ini(:,3)
752	ELSE
753	offset = off_ini(:,2)
754	ENDIF
755	DO i = 1, 8
756	index = iglob + offset(i)
757	ireal = (MIN(MAX(1, index - nbp_lon + 1), klon_glo))
758	IF (pctsrf_g(ireal) > EPSFRA) THEN
759	jj = INT((index - 1)/nbp_lon) + 1
760	ij = index - (jj - 1) * nbp_lon
761	neighbours_g(igrid, i) = correspond(ij, jj)
762	ENDIF
763	ENDDO
764	ENDDO
765
766	ENDIF
767
768	DO i=1,8
769	IF (is_sequential) THEN
770	neighbours(:,i)=neighbours_g(:,i)
771	ELSE
772	#ifdef CPP_MPI
773	IF (knon > 0) THEN
774	! knon>0, scattter global field neighbours_g from master process to local process
775	CALL MPI_SCATTERV(neighbours_g(:,i),knon_nb,displs,MPI_INTEGER,neighbours(:,i),knon,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
776	ELSE
777	! knon=0, no need to save the field for this process
778	CALL MPI_SCATTERV(neighbours_g(:,i),knon_nb,displs,MPI_INTEGER,var_tmp,knon,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
779	END IF
780	#endif
781	ENDIF
782	ENDDO
783
784	END SUBROUTINE Init_neighbours
785	!
786	!****************************************************************************************
787	!
788
789	#endif
790	END MODULE surf_land_orchidee_noopenmp_mod

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

Download in other formats:

Original Format