Context Navigation

surf_land_orchidee_mod.F90 @ 3504

Last change on this file since 3504 was 3504, checked in by yann meurdesoif, 5 years ago

Add some OpenMP synchronisation before calling Orchidee.
In some (very rare) case, it is possible that master thread from LMDZ can call XIOS in the same time than an other thread in ORCHIDEE. Added synchronisation will avoid this problem.

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
Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 29.2 KB

Line
1	!
2	MODULE surf_land_orchidee_mod
3	#ifndef ORCHIDEE_NOOPENMP
4	#ifndef ORCHIDEE_NOZ0H
5	#ifndef ORCHIDEE_NOFREIN
6	#ifndef ORCHIDEE_NOUNSTRUCT
7	!
8	! This module controles the interface towards the model ORCHIDEE.
9	!
10	! Compatibility with ORCHIDIEE :
11	! The current version can be used with ORCHIDEE/trunk from revision 4465.
12	! This interface is used if none of the cpp keys ORCHIDEE_NOOPENMP,
13	! ORCHIDEE_NOZ0H or ORCHIDEE_NOFREIN is set.
14	!
15	! Subroutines in this module : surf_land_orchidee
16	! Init_orchidee_index
17	! Get_orchidee_communicator
18	! Init_neighbours
19
20	USE dimphy
21	#ifdef CPP_VEGET
22	USE intersurf ! module d'ORCHIDEE
23	#endif
24	USE cpl_mod, ONLY : cpl_send_land_fields
25	USE surface_data, ONLY : type_ocean
26	USE geometry_mod, ONLY : dx, dy, boundslon, boundslat,longitude, latitude, cell_area, ind_cell_glo
27	USE mod_grid_phy_lmdz
28	USE mod_phys_lmdz_para, mpi_root_rank=>mpi_master
29	USE carbon_cycle_mod, ONLY : nbcf_in_orc, nbcf_out, fields_in, yfields_in, yfields_out, cfname_in, cfname_out
30	USE nrtype, ONLY : PI
31
32	IMPLICIT NONE
33
34	PRIVATE
35	PUBLIC :: surf_land_orchidee
36
37	CONTAINS
38	!
39	!****************************************************************************************
40	!
41	SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, &
42	knindex, rlon, rlat, yrmu0, pctsrf, &
43	debut, lafin, &
44	plev, u1_lay, v1_lay, gustiness, temp_air, spechum, epot_air, ccanopy, &
45	tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
46	precip_rain, precip_snow, lwdown, swnet, swdown, &
47	ps, q2m, t2m, &
48	evap, fluxsens, fluxlat, &
49	tsol_rad, tsurf_new, alb1_new, alb2_new, &
50	emis_new, z0m_new, z0h_new, qsurf, &
51	veget, lai, height )
52
53	USE mod_surf_para
54	USE mod_synchro_omp
55	USE carbon_cycle_mod
56	USE indice_sol_mod
57	USE print_control_mod, ONLY: lunout
58	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
59	#ifdef CPP_VEGET
60	USE time_phylmdz_mod, ONLY: itau_phy
61	#endif
62	!
63	! Cette routine sert d'interface entre le modele atmospherique et le
64	! modele de sol continental. Appel a sechiba
65	!
66	! L. Fairhead 02/2000
67	!
68	! input:
69	! itime numero du pas de temps
70	! dtime pas de temps de la physique (en s)
71	! nisurf index de la surface a traiter (1 = sol continental)
72	! knon nombre de points de la surface a traiter
73	! knindex index des points de la surface a traiter
74	! rlon longitudes de la grille entiere
75	! rlat latitudes de la grille entiere
76	! pctsrf tableau des fractions de surface de chaque maille
77	! debut logical: 1er appel a la physique (lire les restart)
78	! lafin logical: dernier appel a la physique (ecrire les restart)
79	! (si false calcul simplifie des fluxs sur les continents)
80	! plev hauteur de la premiere couche (Pa)
81	! u1_lay vitesse u 1ere couche
82	! v1_lay vitesse v 1ere couche
83	! temp_air temperature de l'air 1ere couche
84	! spechum humidite specifique 1ere couche
85	! epot_air temp pot de l'air
86	! ccanopy concentration CO2 canopee, correspond au co2_send de
87	! carbon_cycle_mod ou valeur constant co2_ppm
88	! tq_cdrag cdrag
89	! petAcoef coeff. A de la resolution de la CL pour t
90	! peqAcoef coeff. A de la resolution de la CL pour q
91	! petBcoef coeff. B de la resolution de la CL pour t
92	! peqBcoef coeff. B de la resolution de la CL pour q
93	! precip_rain precipitation liquide
94	! precip_snow precipitation solide
95	! lwdown flux IR descendant a la surface
96	! swnet flux solaire net
97	! swdown flux solaire entrant a la surface
98	! ps pression au sol
99	! radsol rayonnement net aus sol (LW + SW)
100	!
101	! output:
102	! evap evaporation totale
103	! fluxsens flux de chaleur sensible
104	! fluxlat flux de chaleur latente
105	! tsol_rad
106	! tsurf_new temperature au sol
107	! alb1_new albedo in visible SW interval
108	! alb2_new albedo in near IR interval
109	! emis_new emissivite
110	! z0m_new surface roughness for momentum
111	! z0h_new surface roughness for heat
112	! qsurf air moisture at surface
113	!
114	INCLUDE "YOMCST.h"
115	INCLUDE "dimpft.h"
116	!
117	! Parametres d'entree
118	!****************************************************************************************
119	INTEGER, INTENT(IN) :: itime
120	REAL, INTENT(IN) :: dtime
121	REAL, INTENT(IN) :: date0
122	INTEGER, INTENT(IN) :: knon
123	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
124	LOGICAL, INTENT(IN) :: debut, lafin
125	REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
126	REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
127	REAL, DIMENSION(klon), INTENT(IN) :: yrmu0 ! cosine of solar zenith angle
128	REAL, DIMENSION(klon), INTENT(IN) :: plev
129	REAL, DIMENSION(klon), INTENT(IN) :: u1_lay, v1_lay, gustiness
130	REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum
131	REAL, DIMENSION(klon), INTENT(IN) :: epot_air, ccanopy
132	REAL, DIMENSION(klon), INTENT(IN) :: tq_cdrag
133	REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef
134	REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef
135	REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow
136	REAL, DIMENSION(klon), INTENT(IN) :: lwdown, swnet, swdown, ps
137	REAL, DIMENSION(klon), INTENT(IN) :: q2m, t2m
138
139	! Parametres de sortie
140	!****************************************************************************************
141	REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat, qsurf
142	REAL, DIMENSION(klon), INTENT(OUT) :: tsol_rad, tsurf_new
143	REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new
144	REAL, DIMENSION(klon), INTENT(OUT) :: emis_new, z0m_new, z0h_new
145	REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: veget
146	REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: lai
147	REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: height
148
149	! Local
150	!****************************************************************************************
151	INTEGER :: ij, jj, igrid, ireal, index, nb
152	INTEGER :: error
153	REAL, DIMENSION(klon) :: swdown_vrai
154	CHARACTER (len = 20) :: modname = 'surf_land_orchidee'
155	CHARACTER (len = 80) :: abort_message
156	LOGICAL,SAVE :: check = .FALSE.
157	!$OMP THREADPRIVATE(check)
158
159	! type de couplage dans sechiba
160	! character (len=10) :: coupling = 'implicit'
161	! drapeaux controlant les appels dans SECHIBA
162	! type(control_type), save :: control_in
163	! Preserved albedo
164	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: albedo_keep, zlev
165	!$OMP THREADPRIVATE(albedo_keep,zlev)
166	! coordonnees geographiques
167	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: lalo
168	!$OMP THREADPRIVATE(lalo)
169	! boundaries of cells
170	REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: bounds_lalo
171	!$OMP THREADPRIVATE(bounds_lalo)
172	! pts voisins
173	INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours
174	!$OMP THREADPRIVATE(neighbours)
175	! fractions continents
176	REAL,ALLOCATABLE, DIMENSION(:), SAVE :: contfrac
177	!$OMP THREADPRIVATE(contfrac)
178	! resolution de la grille
179	REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: resolution
180	!$OMP THREADPRIVATE(resolution)
181
182	REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: lon_scat, lat_scat
183	!$OMP THREADPRIVATE(lon_scat,lat_scat)
184
185	! area of cells
186	REAL, ALLOCATABLE, DIMENSION (:), SAVE :: area
187	!$OMP THREADPRIVATE(area)
188
189	LOGICAL, SAVE :: lrestart_read = .TRUE.
190	!$OMP THREADPRIVATE(lrestart_read)
191	LOGICAL, SAVE :: lrestart_write = .FALSE.
192	!$OMP THREADPRIVATE(lrestart_write)
193
194	REAL, DIMENSION(knon,2) :: albedo_out
195
196	! Pb de nomenclature
197	REAL, DIMENSION(klon) :: petA_orc, peqA_orc
198	REAL, DIMENSION(klon) :: petB_orc, peqB_orc
199	! Pb de correspondances de grilles
200	INTEGER, DIMENSION(:), SAVE, ALLOCATABLE :: ig, jg
201	!$OMP THREADPRIVATE(ig,jg)
202	INTEGER :: indi, indj
203	INTEGER, SAVE, ALLOCATABLE,DIMENSION(:) :: ktindex
204	!$OMP THREADPRIVATE(ktindex)
205
206	! Essai cdrag
207	REAL, DIMENSION(klon) :: cdrag
208	INTEGER,SAVE :: offset
209	!$OMP THREADPRIVATE(offset)
210
211	REAL, DIMENSION(klon_glo) :: rlon_g,rlat_g
212	INTEGER, SAVE :: orch_comm
213	!$OMP THREADPRIVATE(orch_comm)
214
215	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: coastalflow
216	!$OMP THREADPRIVATE(coastalflow)
217	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: riverflow
218	!$OMP THREADPRIVATE(riverflow)
219
220	INTEGER :: orch_mpi_rank
221	INTEGER :: orch_mpi_size
222	INTEGER :: orch_omp_rank
223	INTEGER :: orch_omp_size
224
225	REAL, ALLOCATABLE, DIMENSION(:) :: longitude_glo
226	REAL, ALLOCATABLE, DIMENSION(:) :: latitude_glo
227	REAL, ALLOCATABLE, DIMENSION(:,:) :: boundslon_glo
228	REAL, ALLOCATABLE, DIMENSION(:,:) :: boundslat_glo
229	INTEGER, ALLOCATABLE, DIMENSION(:) :: ind_cell_glo_glo
230	INTEGER, ALLOCATABLE, SAVE,DIMENSION(:) :: ind_cell
231	!$OMP THREADPRIVATE(ind_cell)
232	INTEGER :: begin, end
233	!
234	! Fin definition
235	!****************************************************************************************
236
237	IF (check) WRITE(lunout,*)'Entree ', modname
238
239	! Initialisation
240
241	IF (debut) THEN
242	! Test of coherence between variable ok_veget and cpp key CPP_VEGET
243	#ifndef CPP_VEGET
244	abort_message='Pb de coherence: ok_veget = .true. mais CPP_VEGET = .false.'
245	CALL abort_physic(modname,abort_message,1)
246	#endif
247
248	CALL Init_surf_para(knon)
249	ALLOCATE(ktindex(knon))
250	IF ( .NOT. ALLOCATED(albedo_keep)) THEN
251	!ym ALLOCATE(albedo_keep(klon))
252	!ym bizarre que non alloué en knon precedement
253	ALLOCATE(albedo_keep(knon))
254	ALLOCATE(zlev(knon))
255	ENDIF
256	! Pb de correspondances de grilles
257	ALLOCATE(ig(klon))
258	ALLOCATE(jg(klon))
259	ig(1) = 1
260	jg(1) = 1
261	indi = 0
262	indj = 2
263	DO igrid = 2, klon - 1
264	indi = indi + 1
265	IF ( indi > nbp_lon) THEN
266	indi = 1
267	indj = indj + 1
268	ENDIF
269	ig(igrid) = indi
270	jg(igrid) = indj
271	ENDDO
272	ig(klon) = 1
273	jg(klon) = nbp_lat
274
275	IF ((.NOT. ALLOCATED(area))) THEN
276	ALLOCATE(area(knon), stat = error)
277	IF (error /= 0) THEN
278	abort_message='Pb allocation area'
279	CALL abort_physic(modname,abort_message,1)
280	ENDIF
281	ENDIF
282	DO igrid = 1, knon
283	area(igrid) = cell_area(knindex(igrid))
284	ENDDO
285
286	IF (grid_type==unstructured) THEN
287
288
289	IF ((.NOT. ALLOCATED(lon_scat))) THEN
290	ALLOCATE(lon_scat(nbp_lon,nbp_lat), stat = error)
291	IF (error /= 0) THEN
292	abort_message='Pb allocation lon_scat'
293	CALL abort_physic(modname,abort_message,1)
294	ENDIF
295	ENDIF
296
297	IF ((.NOT. ALLOCATED(lat_scat))) THEN
298	ALLOCATE(lat_scat(nbp_lon,nbp_lat), stat = error)
299	IF (error /= 0) THEN
300	abort_message='Pb allocation lat_scat'
301	CALL abort_physic(modname,abort_message,1)
302	ENDIF
303	ENDIF
304	CALL Gather(rlon,rlon_g)
305	CALL Gather(rlat,rlat_g)
306
307	IF (is_mpi_root) THEN
308	index = 1
309	DO jj = 2, nbp_lat-1
310	DO ij = 1, nbp_lon
311	index = index + 1
312	lon_scat(ij,jj) = rlon_g(index)
313	lat_scat(ij,jj) = rlat_g(index)
314	ENDDO
315	ENDDO
316	lon_scat(:,1) = lon_scat(:,2)
317	lat_scat(:,1) = rlat_g(1)
318	lon_scat(:,nbp_lat) = lon_scat(:,2)
319	lat_scat(:,nbp_lat) = rlat_g(klon_glo)
320	ENDIF
321
322	CALL bcast(lon_scat)
323	CALL bcast(lat_scat)
324
325	ELSE IF (grid_type==regular_lonlat) THEN
326
327	IF ((.NOT. ALLOCATED(lalo))) THEN
328	ALLOCATE(lalo(knon,2), stat = error)
329	IF (error /= 0) THEN
330	abort_message='Pb allocation lalo'
331	CALL abort_physic(modname,abort_message,1)
332	ENDIF
333	ENDIF
334
335	IF ((.NOT. ALLOCATED(bounds_lalo))) THEN
336	ALLOCATE(bounds_lalo(knon,nvertex,2), stat = error)
337	IF (error /= 0) THEN
338	abort_message='Pb allocation lalo'
339	CALL abort_physic(modname,abort_message,1)
340	ENDIF
341	ENDIF
342
343	IF ((.NOT. ALLOCATED(lon_scat))) THEN
344	ALLOCATE(lon_scat(nbp_lon,nbp_lat), stat = error)
345	IF (error /= 0) THEN
346	abort_message='Pb allocation lon_scat'
347	CALL abort_physic(modname,abort_message,1)
348	ENDIF
349	ENDIF
350	IF ((.NOT. ALLOCATED(lat_scat))) THEN
351	ALLOCATE(lat_scat(nbp_lon,nbp_lat), stat = error)
352	IF (error /= 0) THEN
353	abort_message='Pb allocation lat_scat'
354	CALL abort_physic(modname,abort_message,1)
355	ENDIF
356	ENDIF
357	lon_scat = 0.
358	lat_scat = 0.
359	DO igrid = 1, knon
360	index = knindex(igrid)
361	lalo(igrid,2) = rlon(index)
362	lalo(igrid,1) = rlat(index)
363	bounds_lalo(igrid,:,2)=boundslon(index,:)*180./PI
364	bounds_lalo(igrid,:,1)=boundslat(index,:)*180./PI
365	ENDDO
366
367
368
369	CALL Gather(rlon,rlon_g)
370	CALL Gather(rlat,rlat_g)
371
372	IF (is_mpi_root) THEN
373	index = 1
374	DO jj = 2, nbp_lat-1
375	DO ij = 1, nbp_lon
376	index = index + 1
377	lon_scat(ij,jj) = rlon_g(index)
378	lat_scat(ij,jj) = rlat_g(index)
379	ENDDO
380	ENDDO
381	lon_scat(:,1) = lon_scat(:,2)
382	lat_scat(:,1) = rlat_g(1)
383	lon_scat(:,nbp_lat) = lon_scat(:,2)
384	lat_scat(:,nbp_lat) = rlat_g(klon_glo)
385	ENDIF
386
387	CALL bcast(lon_scat)
388	CALL bcast(lat_scat)
389
390	ENDIF
391	!
392	! Allouer et initialiser le tableau des voisins et des fraction de continents
393	!
394	IF (( .NOT. ALLOCATED(contfrac))) THEN
395	ALLOCATE(contfrac(knon), stat = error)
396	IF (error /= 0) THEN
397	abort_message='Pb allocation contfrac'
398	CALL abort_physic(modname,abort_message,1)
399	ENDIF
400	ENDIF
401
402	DO igrid = 1, knon
403	ireal = knindex(igrid)
404	contfrac(igrid) = pctsrf(ireal,is_ter)
405	ENDDO
406
407
408	IF (grid_type==regular_lonlat) THEN
409
410	IF ( (.NOT.ALLOCATED(neighbours))) THEN
411	ALLOCATE(neighbours(knon,8), stat = error)
412	IF (error /= 0) THEN
413	abort_message='Pb allocation neighbours'
414	CALL abort_physic(modname,abort_message,1)
415	ENDIF
416	ENDIF
417	neighbours = -1.
418	CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter))
419
420	ELSE IF (grid_type==unstructured) THEN
421
422	IF ( (.NOT.ALLOCATED(neighbours))) THEN
423	ALLOCATE(neighbours(knon,12), stat = error)
424	IF (error /= 0) THEN
425	abort_message='Pb allocation neighbours'
426	CALL abort_physic(modname,abort_message,1)
427	ENDIF
428	ENDIF
429	neighbours = -1.
430
431	ENDIF
432
433
434	!
435	! Allocation et calcul resolutions
436	IF ( (.NOT.ALLOCATED(resolution))) THEN
437	ALLOCATE(resolution(knon,2), stat = error)
438	IF (error /= 0) THEN
439	abort_message='Pb allocation resolution'
440	CALL abort_physic(modname,abort_message,1)
441	ENDIF
442	ENDIF
443
444	IF (grid_type==regular_lonlat) THEN
445	DO igrid = 1, knon
446	ij = knindex(igrid)
447	resolution(igrid,1) = dx(ij)
448	resolution(igrid,2) = dy(ij)
449	ENDDO
450	ENDIF
451
452	ALLOCATE(coastalflow(klon), stat = error)
453	IF (error /= 0) THEN
454	abort_message='Pb allocation coastalflow'
455	CALL abort_physic(modname,abort_message,1)
456	ENDIF
457
458	ALLOCATE(riverflow(klon), stat = error)
459	IF (error /= 0) THEN
460	abort_message='Pb allocation riverflow'
461	CALL abort_physic(modname,abort_message,1)
462	ENDIF
463	!
464	! carbon_cycle_cpl not possible with this interface and version of ORHCHIDEE
465	!
466	! >> PC
467	! IF (carbon_cycle_cpl) THEN
468	! abort_message='carbon_cycle_cpl not yet possible with this interface of ORCHIDEE'
469	! CALL abort_physic(modname,abort_message,1)
470	! END IF
471	! << PC
472
473	ENDIF ! (fin debut)
474
475	!
476	! Appel a la routine sols continentaux
477	!
478	IF (lafin) lrestart_write = .TRUE.
479	IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write
480
481	petA_orc(1:knon) = petBcoef(1:knon) * dtime
482	petB_orc(1:knon) = petAcoef(1:knon)
483	peqA_orc(1:knon) = peqBcoef(1:knon) * dtime
484	peqB_orc(1:knon) = peqAcoef(1:knon)
485
486	cdrag = 0.
487	cdrag(1:knon) = tq_cdrag(1:knon)
488
489	! zlev(1:knon) = (100.plev(1:knon))/((ps(1:knon)/287.05temp_air(1:knon))*9.80665)
490	! zlev(1:knon) = (100.plev(1:knon))/((ps(1:knon)/RDtemp_air(1:knon))*RG)
491	zlev(1:knon) = plev(1:knon)RDtemp_air(1:knon)/((ps(1:knon)100.0)RG)
492
493
494	! PF et PASB
495	! where(cdrag > 0.01)
496	! cdrag = 0.01
497	! endwhere
498	! write(,)'Cdrag = ',minval(cdrag),maxval(cdrag)
499
500
501	IF (debut) THEN
502	CALL Init_orchidee_index(knon,knindex,offset,ktindex)
503	CALL Get_orchidee_communicator(orch_comm,orch_mpi_size,orch_mpi_rank, orch_omp_size,orch_omp_rank)
504
505	IF (grid_type==unstructured) THEN
506	IF (knon==0) THEN
507	begin=1
508	end=0
509	ELSE
510	begin=offset+1
511	end=offset+ktindex(knon)
512	ENDIF
513
514	IF (orch_mpi_rank==orch_mpi_size-1 .AND. orch_omp_rank==orch_omp_size-1) end=nbp_lon*nbp_lat
515
516	ALLOCATE(lalo(end-begin+1,2))
517	ALLOCATE(bounds_lalo(end-begin+1,nvertex,2))
518	ALLOCATE(ind_cell(end-begin+1))
519
520	ALLOCATE(longitude_glo(klon_glo))
521	CALL gather(longitude,longitude_glo)
522	CALL bcast(longitude_glo)
523	lalo(:,2)=longitude_glo(begin:end)*180./PI
524
525	ALLOCATE(latitude_glo(klon_glo))
526	CALL gather(latitude,latitude_glo)
527	CALL bcast(latitude_glo)
528	lalo(:,1)=latitude_glo(begin:end)*180./PI
529
530	ALLOCATE(boundslon_glo(klon_glo,nvertex))
531	CALL gather(boundslon,boundslon_glo)
532	CALL bcast(boundslon_glo)
533	bounds_lalo(:,:,2)=boundslon_glo(begin:end,:)*180./PI
534
535	ALLOCATE(boundslat_glo(klon_glo,nvertex))
536	CALL gather(boundslat,boundslat_glo)
537	CALL bcast(boundslat_glo)
538	bounds_lalo(:,:,1)=boundslat_glo(begin:end,:)*180./PI
539
540	ALLOCATE(ind_cell_glo_glo(klon_glo))
541	CALL gather(ind_cell_glo,ind_cell_glo_glo)
542	CALL bcast(ind_cell_glo_glo)
543	ind_cell(:)=ind_cell_glo_glo(begin:end)
544
545	ENDIF
546	CALL Init_synchro_omp
547
548	!$OMP BARRIER
549
550	IF (knon > 0) THEN
551	#ifdef CPP_VEGET
552	CALL Init_intersurf(nbp_lon,nbp_lat,knon,ktindex,offset,orch_omp_size,orch_omp_rank,orch_comm,grid=grid_type)
553	#endif
554	ENDIF
555
556	CALL Synchro_omp
557
558
559	IF (knon > 0) THEN
560
561	print *,'OB before intersurf=', SIZE(cfname_in), SIZE(cfname_out)
562	#ifdef CPP_VEGET
563
564	CALL intersurf_initialize_gathered (itime+itau_phy-1, nbp_lon, nbp_lat, knon, ktindex, dtime, &
565	lrestart_read, lrestart_write, lalo, contfrac, neighbours, resolution, date0, &
566	zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, &
567	cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
568	precip_rain, precip_snow, lwdown, swnet, swdown, ps, &
569	evap, fluxsens, fluxlat, coastalflow, riverflow, &
570	tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0m_new, &
571	lon_scat, lat_scat, q2m(1:knon), t2m(1:knon), z0h_new(1:knon), nvm_orch, &
572	grid=grid_type, bounds_latlon=bounds_lalo, cell_area=area, ind_cell_glo=ind_cell, &
573	field_out_names=cfname_out, field_in_names=cfname_in(1:nbcf_in_orc))
574	#endif
575	ENDIF
576
577	CALL Synchro_omp
578
579	albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
580
581	ENDIF
582
583	! swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon))
584	swdown_vrai(1:knon) = swdown(1:knon)
585	!$OMP BARRIER
586
587	IF (knon > 0) THEN
588	#ifdef CPP_VEGET
589	IF (nvm_orch .NE. nvm_lmdz ) THEN
590	abort_message='Pb de dimensiosn PFT: nvm_orch et nvm_lmdz differents.'
591	CALL abort_physic(modname,abort_message,1)
592	ENDIF
593
594	CALL intersurf_main_gathered (itime+itau_phy, nbp_lon, nbp_lat, knon, ktindex, dtime, &
595	lrestart_read, lrestart_write, lalo, &
596	contfrac, neighbours, resolution, date0, &
597	zlev, u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
598	cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
599	precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), &
600	evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
601	tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0m_new(1:knon), &
602	lon_scat, lat_scat, q2m(1:knon), t2m(1:knon), z0h_new(1:knon),&
603	veget(1:knon,:),lai(1:knon,:),height(1:knon,:),&
604	fields_out=yfields_out(1:knon,1:nbcf_out), &
605	fields_in=yfields_in(1:knon,1:nbcf_in_orc), &
606	coszang=yrmu0(1:knon))
607	#endif
608	ENDIF
609
610	CALL Synchro_omp
611
612	albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
613
614	!* Send to coupler
615	!
616	IF (type_ocean=='couple') THEN
617	CALL cpl_send_land_fields(itime, knon, knindex, &
618	riverflow, coastalflow)
619	ENDIF
620
621	alb1_new(1:knon) = albedo_out(1:knon,1)
622	alb2_new(1:knon) = albedo_out(1:knon,2)
623
624	! Convention orchidee: positif vers le haut
625	fluxsens(1:knon) = -1. * fluxsens(1:knon)
626	fluxlat(1:knon) = -1. * fluxlat(1:knon)
627
628	! evap = -1. * evap
629
630	IF (debut) lrestart_read = .FALSE.
631
632	IF (debut) CALL Finalize_surf_para
633
634	! >> PC
635	! Decompressing variables into LMDz for the module carbon_cycle_mod
636	! nbcf_in can be zero, in which case the loop does not operate
637	! fields_in can then used elsewhere in the model
638
639	fields_in(:,:)=0.0
640
641	DO nb=1, nbcf_in_orc
642	DO igrid = 1, knon
643	ireal = knindex(igrid)
644	fields_in(ireal,nb)=yfields_in(igrid,nb)
645	ENDDO
646	WRITE(,) 'surf_land_orchidee_mod --- yfields_in :',cfname_in(nb)
647	ENDDO
648	! >> PC
649
650	END SUBROUTINE surf_land_orchidee
651	!
652	!****************************************************************************************
653	!
654	SUBROUTINE Init_orchidee_index(knon,knindex,offset,ktindex)
655	USE mod_surf_para
656	USE mod_grid_phy_lmdz
657
658	INTEGER,INTENT(IN) :: knon
659	INTEGER,INTENT(IN) :: knindex(klon)
660	INTEGER,INTENT(OUT) :: offset
661	INTEGER,INTENT(OUT) :: ktindex(klon)
662
663	INTEGER :: ktindex_glo(knon_glo)
664	INTEGER :: offset_para(0:omp_size*mpi_size-1)
665	INTEGER :: LastPoint
666	INTEGER :: task
667
668	ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1
669
670	CALL gather_surf(ktindex(1:knon),ktindex_glo)
671
672	IF (is_mpi_root .AND. is_omp_root) THEN
673	LastPoint=0
674	DO Task=0,mpi_size*omp_size-1
675	IF (knon_glo_para(Task)>0) THEN
676	offset_para(task)= LastPoint-MOD(LastPoint,nbp_lon)
677	LastPoint=ktindex_glo(knon_glo_end_para(task))
678	ENDIF
679	ENDDO
680	ENDIF
681
682	CALL bcast(offset_para)
683
684	offset=offset_para(omp_size*mpi_rank+omp_rank)
685
686	ktindex(1:knon)=ktindex(1:knon)-offset
687
688	END SUBROUTINE Init_orchidee_index
689
690	!
691	!*********************** *************************************************************
692	!
693
694	SUBROUTINE Get_orchidee_communicator(orch_comm, orch_mpi_size, orch_mpi_rank, orch_omp_size,orch_omp_rank)
695	USE mod_surf_para
696
697	#ifdef CPP_MPI
698	INCLUDE 'mpif.h'
699	#endif
700
701	INTEGER,INTENT(OUT) :: orch_comm
702	INTEGER,INTENT(OUT) :: orch_mpi_size
703	INTEGER,INTENT(OUT) :: orch_mpi_rank
704	INTEGER,INTENT(OUT) :: orch_omp_size
705	INTEGER,INTENT(OUT) :: orch_omp_rank
706	INTEGER :: color
707	INTEGER :: i,ierr
708	!
709	! End definition
710	!****************************************************************************************
711
712	IF (is_omp_root) THEN
713
714	IF (knon_mpi==0) THEN
715	color = 0
716	ELSE
717	color = 1
718	ENDIF
719
720	#ifdef CPP_MPI
721	CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr)
722	CALL MPI_COMM_SIZE(orch_comm,orch_mpi_size,ierr)
723	CALL MPI_COMM_RANK(orch_comm,orch_mpi_rank,ierr)
724	#endif
725
726	ENDIF
727	CALL bcast_omp(orch_comm)
728
729	IF (knon_mpi /= 0) THEN
730	orch_omp_size=0
731	DO i=0,omp_size-1
732	IF (knon_omp_para(i) /=0) THEN
733	orch_omp_size=orch_omp_size+1
734	IF (i==omp_rank) orch_omp_rank=orch_omp_size-1
735	ENDIF
736	ENDDO
737	ENDIF
738
739	END SUBROUTINE Get_orchidee_communicator
740	!
741	!****************************************************************************************
742	!
743
744	SUBROUTINE Init_neighbours(knon,neighbours,knindex,pctsrf)
745	USE mod_grid_phy_lmdz
746	USE mod_surf_para
747	USE indice_sol_mod
748
749	#ifdef CPP_MPI
750	INCLUDE 'mpif.h'
751	#endif
752
753	! Input arguments
754	!****************************************************************************************
755	INTEGER, INTENT(IN) :: knon
756	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
757	REAL, DIMENSION(klon), INTENT(IN) :: pctsrf
758
759	! Output arguments
760	!****************************************************************************************
761	INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours
762
763	! Local variables
764	!****************************************************************************************
765	INTEGER :: i, igrid, jj, ij, iglob
766	INTEGER :: ierr, ireal, index
767	INTEGER, DIMENSION(8,3) :: off_ini
768	INTEGER, DIMENSION(8) :: offset
769	INTEGER, DIMENSION(nbp_lon,nbp_lat) :: correspond
770	INTEGER, DIMENSION(knon_glo) :: ktindex_glo
771	INTEGER, DIMENSION(knon_glo,8) :: neighbours_glo
772	REAL, DIMENSION(klon_glo) :: pctsrf_glo
773	INTEGER :: ktindex(klon)
774	!
775	! End definition
776	!****************************************************************************************
777
778	ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1
779
780	CALL gather_surf(ktindex(1:knon),ktindex_glo)
781	CALL gather(pctsrf,pctsrf_glo)
782
783	IF (is_mpi_root .AND. is_omp_root) THEN
784	neighbours_glo(:,:)=-1
785	! Initialisation des offset
786	!
787	! offset bord ouest
788	off_ini(1,1) = - nbp_lon ; off_ini(2,1) = - nbp_lon + 1 ; off_ini(3,1) = 1
789	off_ini(4,1) = nbp_lon + 1 ; off_ini(5,1) = nbp_lon ; off_ini(6,1) = 2 * nbp_lon - 1
790	off_ini(7,1) = nbp_lon -1 ; off_ini(8,1) = - 1
791	! offset point normal
792	off_ini(1,2) = - nbp_lon ; off_ini(2,2) = - nbp_lon + 1 ; off_ini(3,2) = 1
793	off_ini(4,2) = nbp_lon + 1 ; off_ini(5,2) = nbp_lon ; off_ini(6,2) = nbp_lon - 1
794	off_ini(7,2) = -1 ; off_ini(8,2) = - nbp_lon - 1
795	! offset bord est
796	off_ini(1,3) = - nbp_lon ; off_ini(2,3) = - 2 * nbp_lon + 1 ; off_ini(3,3) = - nbp_lon + 1
797	off_ini(4,3) = 1 ; off_ini(5,3) = nbp_lon ; off_ini(6,3) = nbp_lon - 1
798	off_ini(7,3) = -1 ; off_ini(8,3) = - nbp_lon - 1
799	!
800	! Attention aux poles
801	!
802	DO igrid = 1, knon_glo
803	index = ktindex_glo(igrid)
804	jj = INT((index - 1)/nbp_lon) + 1
805	ij = index - (jj - 1) * nbp_lon
806	correspond(ij,jj) = igrid
807	ENDDO
808	!sonia : Les mailles des voisines doivent etre toutes egales (pour couplage orchidee)
809	IF (knon_glo == 1) THEN
810	igrid = 1
811	DO i = 1,8
812	neighbours_glo(igrid, i) = igrid
813	ENDDO
814	ELSE
815
816	DO igrid = 1, knon_glo
817	iglob = ktindex_glo(igrid)
818
819	IF (MOD(iglob, nbp_lon) == 1) THEN
820	offset = off_ini(:,1)
821	ELSE IF(MOD(iglob, nbp_lon) == 0) THEN
822	offset = off_ini(:,3)
823	ELSE
824	offset = off_ini(:,2)
825	ENDIF
826
827	DO i = 1, 8
828	index = iglob + offset(i)
829	ireal = (MIN(MAX(1, index - nbp_lon + 1), klon_glo))
830	IF (pctsrf_glo(ireal) > EPSFRA) THEN
831	jj = INT((index - 1)/nbp_lon) + 1
832	ij = index - (jj - 1) * nbp_lon
833	neighbours_glo(igrid, i) = correspond(ij, jj)
834	ENDIF
835	ENDDO
836	ENDDO
837	ENDIF !fin knon_glo == 1
838
839	ENDIF
840
841	DO i = 1, 8
842	CALL scatter_surf(neighbours_glo(:,i),neighbours(1:knon,i))
843	ENDDO
844	END SUBROUTINE Init_neighbours
845
846	!
847	!****************************************************************************************
848	!
849	#endif
850	#endif
851	#endif
852	#endif
853	END MODULE surf_land_orchidee_mod

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

Download in other formats:

Original Format