Context Navigation

surf_land_orchidee_mod.F90 @ 2306

Last change on this file since 2306 was 2240, checked in by fhourdin, 10 years ago

Revisite de la formule des flux de surface
(en priorité sur l'océan) en tenant compte des bourrasques de
vent et de la différence entre les hauteurs de rugosités pour
la quantité de mouvement, l'enthalpie et éventuellement l'humidité.

Etape 1 :
Introduction d'un calcul de gustiness dans la physique
gustiness(:)=f_gust_bl * ale_bl + f_gust_wk * ame_wk
Cette variable est passée ensuite jusqu'au fin fond de la couche limite.
L'étape 1 est prête à commettre, ne nécessite pas de nouvelles
variables dans les startphy et assure la convergence numérique.

Introduction of gustiness in the surface flux computation.
Gustiness is computed from as
gustiness(:)=f_gust_bl * ale_bl + f_gust_wk * ame_wk
and pass through pbl_surface down to the routines that compute
surface fluxes.

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:executable set to *
Property svn:keywords set to Author Date Id Revision

File size: 22.1 KB

Line
1	!
2	MODULE surf_land_orchidee_mod
3	#ifndef ORCHIDEE_NOOPENMP
4	!
5	! This module controles the interface towards the model ORCHIDEE
6	!
7	! Subroutines in this module : surf_land_orchidee
8	! Init_orchidee_index
9	! Get_orchidee_communicator
10	! Init_neighbours
11
12	USE dimphy
13	#ifdef CPP_VEGET
14	USE intersurf ! module d'ORCHIDEE
15	#endif
16	USE cpl_mod, ONLY : cpl_send_land_fields
17	USE surface_data, ONLY : type_ocean
18	USE comgeomphy, ONLY : cuphy, cvphy
19	USE mod_grid_phy_lmdz
20	USE mod_phys_lmdz_para, mpi_root_rank=>mpi_root
21
22	IMPLICIT NONE
23
24	PRIVATE
25	PUBLIC :: surf_land_orchidee
26
27	LOGICAL, ALLOCATABLE, SAVE :: flag_omp(:)
28	CONTAINS
29	!
30	!****************************************************************************************
31	!
32	SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, &
33	knindex, rlon, rlat, pctsrf, &
34	debut, lafin, &
35	plev, u1_lay, v1_lay, gustiness, temp_air, spechum, epot_air, ccanopy, &
36	tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
37	precip_rain, precip_snow, lwdown, swnet, swdown, &
38	ps, q2m, t2m, &
39	evap, fluxsens, fluxlat, &
40	tsol_rad, tsurf_new, alb1_new, alb2_new, &
41	emis_new, z0_new, qsurf)
42
43	USE mod_surf_para
44	USE mod_synchro_omp
45	USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
46	USE indice_sol_mod
47
48	!
49	! Cette routine sert d'interface entre le modele atmospherique et le
50	! modele de sol continental. Appel a sechiba
51	!
52	! L. Fairhead 02/2000
53	!
54	! input:
55	! itime numero du pas de temps
56	! dtime pas de temps de la physique (en s)
57	! nisurf index de la surface a traiter (1 = sol continental)
58	! knon nombre de points de la surface a traiter
59	! knindex index des points de la surface a traiter
60	! rlon longitudes de la grille entiere
61	! rlat latitudes de la grille entiere
62	! pctsrf tableau des fractions de surface de chaque maille
63	! debut logical: 1er appel a la physique (lire les restart)
64	! lafin logical: dernier appel a la physique (ecrire les restart)
65	! (si false calcul simplifie des fluxs sur les continents)
66	! plev hauteur de la premiere couche (Pa)
67	! u1_lay vitesse u 1ere couche
68	! v1_lay vitesse v 1ere couche
69	! temp_air temperature de l'air 1ere couche
70	! spechum humidite specifique 1ere couche
71	! epot_air temp pot de l'air
72	! ccanopy concentration CO2 canopee, correspond au co2_send de
73	! carbon_cycle_mod ou valeur constant co2_ppm
74	! tq_cdrag cdrag
75	! petAcoef coeff. A de la resolution de la CL pour t
76	! peqAcoef coeff. A de la resolution de la CL pour q
77	! petBcoef coeff. B de la resolution de la CL pour t
78	! peqBcoef coeff. B de la resolution de la CL pour q
79	! precip_rain precipitation liquide
80	! precip_snow precipitation solide
81	! lwdown flux IR descendant a la surface
82	! swnet flux solaire net
83	! swdown flux solaire entrant a la surface
84	! ps pression au sol
85	! radsol rayonnement net aus sol (LW + SW)
86	!
87	!
88	! output:
89	! evap evaporation totale
90	! fluxsens flux de chaleur sensible
91	! fluxlat flux de chaleur latente
92	! tsol_rad
93	! tsurf_new temperature au sol
94	! alb1_new albedo in visible SW interval
95	! alb2_new albedo in near IR interval
96	! emis_new emissivite
97	! z0_new surface roughness
98	! qsurf air moisture at surface
99	!
100	INCLUDE "temps.h"
101	INCLUDE "YOMCST.h"
102	INCLUDE "iniprint.h"
103	INCLUDE "dimensions.h"
104
105	!
106	! Parametres d'entree
107	!****************************************************************************************
108	INTEGER, INTENT(IN) :: itime
109	REAL, INTENT(IN) :: dtime
110	REAL, INTENT(IN) :: date0
111	INTEGER, INTENT(IN) :: knon
112	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
113	LOGICAL, INTENT(IN) :: debut, lafin
114	REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
115	REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
116	REAL, DIMENSION(klon), INTENT(IN) :: plev
117	REAL, DIMENSION(klon), INTENT(IN) :: u1_lay, v1_lay, gustiness
118	REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum
119	REAL, DIMENSION(klon), INTENT(IN) :: epot_air, ccanopy
120	REAL, DIMENSION(klon), INTENT(IN) :: tq_cdrag
121	REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef
122	REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef
123	REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow
124	REAL, DIMENSION(klon), INTENT(IN) :: lwdown, swnet, swdown, ps
125	REAL, DIMENSION(klon), INTENT(IN) :: q2m, t2m
126
127	! Parametres de sortie
128	!****************************************************************************************
129	REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat, qsurf
130	REAL, DIMENSION(klon), INTENT(OUT) :: tsol_rad, tsurf_new
131	REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new
132	REAL, DIMENSION(klon), INTENT(OUT) :: emis_new, z0_new
133
134	! Local
135	!****************************************************************************************
136	INTEGER :: ij, jj, igrid, ireal, index
137	INTEGER :: error
138	REAL, DIMENSION(klon) :: swdown_vrai
139	CHARACTER (len = 20) :: modname = 'surf_land_orchidee'
140	CHARACTER (len = 80) :: abort_message
141	LOGICAL,SAVE :: check = .FALSE.
142	!$OMP THREADPRIVATE(check)
143
144	! type de couplage dans sechiba
145	! character (len=10) :: coupling = 'implicit'
146	! drapeaux controlant les appels dans SECHIBA
147	! type(control_type), save :: control_in
148	! Preserved albedo
149	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: albedo_keep, zlev
150	!$OMP THREADPRIVATE(albedo_keep,zlev)
151	! coordonnees geographiques
152	REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: lalo
153	!$OMP THREADPRIVATE(lalo)
154	! pts voisins
155	INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours
156	!$OMP THREADPRIVATE(neighbours)
157	! fractions continents
158	REAL,ALLOCATABLE, DIMENSION(:), SAVE :: contfrac
159	!$OMP THREADPRIVATE(contfrac)
160	! resolution de la grille
161	REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: resolution
162	!$OMP THREADPRIVATE(resolution)
163
164	REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: lon_scat, lat_scat
165	!$OMP THREADPRIVATE(lon_scat,lat_scat)
166
167	LOGICAL, SAVE :: lrestart_read = .TRUE.
168	!$OMP THREADPRIVATE(lrestart_read)
169	LOGICAL, SAVE :: lrestart_write = .FALSE.
170	!$OMP THREADPRIVATE(lrestart_write)
171
172	REAL, DIMENSION(knon,2) :: albedo_out
173
174	! Pb de nomenclature
175	REAL, DIMENSION(klon) :: petA_orc, peqA_orc
176	REAL, DIMENSION(klon) :: petB_orc, peqB_orc
177	! Pb de correspondances de grilles
178	INTEGER, DIMENSION(:), SAVE, ALLOCATABLE :: ig, jg
179	!$OMP THREADPRIVATE(ig,jg)
180	INTEGER :: indi, indj
181	INTEGER, SAVE, ALLOCATABLE,DIMENSION(:) :: ktindex
182	!$OMP THREADPRIVATE(ktindex)
183
184	! Essai cdrag
185	REAL, DIMENSION(klon) :: cdrag
186	INTEGER,SAVE :: offset
187	!$OMP THREADPRIVATE(offset)
188
189	REAL, DIMENSION(klon_glo) :: rlon_g,rlat_g
190	INTEGER, SAVE :: orch_comm
191	!$OMP THREADPRIVATE(orch_comm)
192
193	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: coastalflow
194	!$OMP THREADPRIVATE(coastalflow)
195	REAL, ALLOCATABLE, DIMENSION(:), SAVE :: riverflow
196	!$OMP THREADPRIVATE(riverflow)
197
198	INTEGER :: orch_omp_rank
199	INTEGER :: orch_omp_size
200	!
201	! Fin definition
202	!****************************************************************************************
203
204	IF (check) WRITE(lunout,*)'Entree ', modname
205
206	! Initialisation
207
208	IF (debut) THEN
209	! Test of coherence between variable ok_veget and cpp key CPP_VEGET
210	#ifndef CPP_VEGET
211	abort_message='Pb de coherence: ok_veget = .true. mais CPP_VEGET = .false.'
212	CALL abort_gcm(modname,abort_message,1)
213	#endif
214
215	CALL Init_surf_para(knon)
216	ALLOCATE(ktindex(knon))
217	IF ( .NOT. ALLOCATED(albedo_keep)) THEN
218	!ym ALLOCATE(albedo_keep(klon))
219	!ym bizarre que non alloué en knon precedement
220	ALLOCATE(albedo_keep(knon))
221	ALLOCATE(zlev(knon))
222	ENDIF
223	! Pb de correspondances de grilles
224	ALLOCATE(ig(klon))
225	ALLOCATE(jg(klon))
226	ig(1) = 1
227	jg(1) = 1
228	indi = 0
229	indj = 2
230	DO igrid = 2, klon - 1
231	indi = indi + 1
232	IF ( indi > iim) THEN
233	indi = 1
234	indj = indj + 1
235	ENDIF
236	ig(igrid) = indi
237	jg(igrid) = indj
238	ENDDO
239	ig(klon) = 1
240	jg(klon) = jjm + 1
241
242	IF ((.NOT. ALLOCATED(lalo))) THEN
243	ALLOCATE(lalo(knon,2), stat = error)
244	IF (error /= 0) THEN
245	abort_message='Pb allocation lalo'
246	CALL abort_gcm(modname,abort_message,1)
247	ENDIF
248	ENDIF
249	IF ((.NOT. ALLOCATED(lon_scat))) THEN
250	ALLOCATE(lon_scat(iim,jjm+1), stat = error)
251	IF (error /= 0) THEN
252	abort_message='Pb allocation lon_scat'
253	CALL abort_gcm(modname,abort_message,1)
254	ENDIF
255	ENDIF
256	IF ((.NOT. ALLOCATED(lat_scat))) THEN
257	ALLOCATE(lat_scat(iim,jjm+1), stat = error)
258	IF (error /= 0) THEN
259	abort_message='Pb allocation lat_scat'
260	CALL abort_gcm(modname,abort_message,1)
261	ENDIF
262	ENDIF
263	lon_scat = 0.
264	lat_scat = 0.
265	DO igrid = 1, knon
266	index = knindex(igrid)
267	lalo(igrid,2) = rlon(index)
268	lalo(igrid,1) = rlat(index)
269	ENDDO
270
271
272
273	CALL Gather(rlon,rlon_g)
274	CALL Gather(rlat,rlat_g)
275
276	IF (is_mpi_root) THEN
277	index = 1
278	DO jj = 2, jjm
279	DO ij = 1, iim
280	index = index + 1
281	lon_scat(ij,jj) = rlon_g(index)
282	lat_scat(ij,jj) = rlat_g(index)
283	ENDDO
284	ENDDO
285	lon_scat(:,1) = lon_scat(:,2)
286	lat_scat(:,1) = rlat_g(1)
287	lon_scat(:,jjm+1) = lon_scat(:,2)
288	lat_scat(:,jjm+1) = rlat_g(klon_glo)
289	ENDIF
290
291	CALL bcast(lon_scat)
292	CALL bcast(lat_scat)
293	!
294	! Allouer et initialiser le tableau des voisins et des fraction de continents
295	!
296	IF ( (.NOT.ALLOCATED(neighbours))) THEN
297	ALLOCATE(neighbours(knon,8), stat = error)
298	IF (error /= 0) THEN
299	abort_message='Pb allocation neighbours'
300	CALL abort_gcm(modname,abort_message,1)
301	ENDIF
302	ENDIF
303	neighbours = -1.
304	IF (( .NOT. ALLOCATED(contfrac))) THEN
305	ALLOCATE(contfrac(knon), stat = error)
306	IF (error /= 0) THEN
307	abort_message='Pb allocation contfrac'
308	CALL abort_gcm(modname,abort_message,1)
309	ENDIF
310	ENDIF
311
312	DO igrid = 1, knon
313	ireal = knindex(igrid)
314	contfrac(igrid) = pctsrf(ireal,is_ter)
315	ENDDO
316
317
318	CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter))
319
320	!
321	! Allocation et calcul resolutions
322	IF ( (.NOT.ALLOCATED(resolution))) THEN
323	ALLOCATE(resolution(knon,2), stat = error)
324	IF (error /= 0) THEN
325	abort_message='Pb allocation resolution'
326	CALL abort_gcm(modname,abort_message,1)
327	ENDIF
328	ENDIF
329	DO igrid = 1, knon
330	ij = knindex(igrid)
331	resolution(igrid,1) = cuphy(ij)
332	resolution(igrid,2) = cvphy(ij)
333	ENDDO
334
335	ALLOCATE(coastalflow(klon), stat = error)
336	IF (error /= 0) THEN
337	abort_message='Pb allocation coastalflow'
338	CALL abort_gcm(modname,abort_message,1)
339	ENDIF
340
341	ALLOCATE(riverflow(klon), stat = error)
342	IF (error /= 0) THEN
343	abort_message='Pb allocation riverflow'
344	CALL abort_gcm(modname,abort_message,1)
345	ENDIF
346	!
347	! carbon_cycle_cpl not possible with this interface and version of ORHCHIDEE
348	!
349	IF (carbon_cycle_cpl) THEN
350	abort_message='carbon_cycle_cpl not yet possible with this interface of ORCHIDEE'
351	CALL abort_gcm(modname,abort_message,1)
352	END IF
353
354	ENDIF ! (fin debut)
355
356
357	!
358	! Appel a la routine sols continentaux
359	!
360	IF (lafin) lrestart_write = .TRUE.
361	IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write
362
363	petA_orc(1:knon) = petBcoef(1:knon) * dtime
364	petB_orc(1:knon) = petAcoef(1:knon)
365	peqA_orc(1:knon) = peqBcoef(1:knon) * dtime
366	peqB_orc(1:knon) = peqAcoef(1:knon)
367
368	cdrag = 0.
369	cdrag(1:knon) = tq_cdrag(1:knon)
370
371	! zlev(1:knon) = (100.plev(1:knon))/((ps(1:knon)/287.05temp_air(1:knon))*9.80665)
372	! zlev(1:knon) = (100.plev(1:knon))/((ps(1:knon)/RDtemp_air(1:knon))*RG)
373	zlev(1:knon) = plev(1:knon)RDtemp_air(1:knon)/((ps(1:knon)100.0)RG)
374
375
376	! PF et PASB
377	! where(cdrag > 0.01)
378	! cdrag = 0.01
379	! endwhere
380	! write(,)'Cdrag = ',minval(cdrag),maxval(cdrag)
381
382
383	IF (debut) THEN
384	CALL Init_orchidee_index(knon,knindex,offset,ktindex)
385	CALL Get_orchidee_communicator(orch_comm,orch_omp_size,orch_omp_rank)
386	CALL Init_synchro_omp
387
388	IF (knon > 0) THEN
389	#ifdef CPP_VEGET
390	CALL Init_intersurf(nbp_lon,nbp_lat,knon,ktindex,offset,orch_omp_size,orch_omp_rank,orch_comm)
391	#endif
392	ENDIF
393
394
395	IF (knon > 0) THEN
396
397	#ifdef CPP_VEGET
398	CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, knon, ktindex, dtime, &
399	lrestart_read, lrestart_write, lalo, &
400	contfrac, neighbours, resolution, date0, &
401	zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
402	cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
403	precip_rain, precip_snow, lwdown, swnet, swdown, ps, &
404	evap, fluxsens, fluxlat, coastalflow, riverflow, &
405	tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
406	lon_scat, lat_scat, q2m, t2m)
407	#endif
408	ENDIF
409
410	CALL Synchro_omp
411
412	albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
413
414	ENDIF
415
416
417	! swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon))
418	swdown_vrai(1:knon) = swdown(1:knon)
419
420	IF (knon > 0) THEN
421	#ifdef CPP_VEGET
422	CALL intersurf_main (itime+itau_phy, iim, jjm+1, knon, ktindex, dtime, &
423	lrestart_read, lrestart_write, lalo, &
424	contfrac, neighbours, resolution, date0, &
425	zlev, u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
426	cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
427	precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), &
428	evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
429	tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
430	lon_scat, lat_scat, q2m, t2m)
431	#endif
432	ENDIF
433
434	CALL Synchro_omp
435
436	albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
437
438	!* Send to coupler
439	!
440	IF (type_ocean=='couple') THEN
441	CALL cpl_send_land_fields(itime, knon, knindex, &
442	riverflow, coastalflow)
443	ENDIF
444
445	alb1_new(1:knon) = albedo_out(1:knon,1)
446	alb2_new(1:knon) = albedo_out(1:knon,2)
447
448	! Convention orchidee: positif vers le haut
449	fluxsens(1:knon) = -1. * fluxsens(1:knon)
450	fluxlat(1:knon) = -1. * fluxlat(1:knon)
451
452	! evap = -1. * evap
453
454	IF (debut) lrestart_read = .FALSE.
455
456	IF (debut) CALL Finalize_surf_para
457
458
459	END SUBROUTINE surf_land_orchidee
460	!
461	!****************************************************************************************
462	!
463	SUBROUTINE Init_orchidee_index(knon,knindex,offset,ktindex)
464	USE mod_surf_para
465	USE mod_grid_phy_lmdz
466
467	INTEGER,INTENT(IN) :: knon
468	INTEGER,INTENT(IN) :: knindex(klon)
469	INTEGER,INTENT(OUT) :: offset
470	INTEGER,INTENT(OUT) :: ktindex(klon)
471
472	INTEGER :: ktindex_glo(knon_glo)
473	INTEGER :: offset_para(0:omp_size*mpi_size-1)
474	INTEGER :: LastPoint
475	INTEGER :: task
476
477	ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1
478
479	CALL gather_surf(ktindex(1:knon),ktindex_glo)
480
481	IF (is_mpi_root .AND. is_omp_root) THEN
482	LastPoint=0
483	DO Task=0,mpi_size*omp_size-1
484	IF (knon_glo_para(Task)>0) THEN
485	offset_para(task)= LastPoint-MOD(LastPoint,nbp_lon)
486	LastPoint=ktindex_glo(knon_glo_end_para(task))
487	ENDIF
488	ENDDO
489	ENDIF
490
491	CALL bcast(offset_para)
492
493	offset=offset_para(omp_size*mpi_rank+omp_rank)
494
495	ktindex(1:knon)=ktindex(1:knon)-offset
496
497	END SUBROUTINE Init_orchidee_index
498
499	!
500	!*********************** *************************************************************
501	!
502
503	SUBROUTINE Get_orchidee_communicator(orch_comm,orch_omp_size,orch_omp_rank)
504	USE mod_surf_para
505
506	#ifdef CPP_MPI
507	INCLUDE 'mpif.h'
508	#endif
509
510	INTEGER,INTENT(OUT) :: orch_comm
511	INTEGER,INTENT(OUT) :: orch_omp_size
512	INTEGER,INTENT(OUT) :: orch_omp_rank
513	INTEGER :: color
514	INTEGER :: i,ierr
515	!
516	! End definition
517	!****************************************************************************************
518
519
520	IF (is_omp_root) THEN
521
522	IF (knon_mpi==0) THEN
523	color = 0
524	ELSE
525	color = 1
526	ENDIF
527
528	#ifdef CPP_MPI
529	CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr)
530	#endif
531
532	ENDIF
533	CALL bcast_omp(orch_comm)
534
535	IF (knon_mpi /= 0) THEN
536	orch_omp_size=0
537	DO i=0,omp_size-1
538	IF (knon_omp_para(i) /=0) THEN
539	orch_omp_size=orch_omp_size+1
540	IF (i==omp_rank) orch_omp_rank=orch_omp_size-1
541	ENDIF
542	ENDDO
543	ENDIF
544
545
546	END SUBROUTINE Get_orchidee_communicator
547	!
548	!****************************************************************************************
549	!
550
551	SUBROUTINE Init_neighbours(knon,neighbours,knindex,pctsrf)
552	USE mod_grid_phy_lmdz
553	USE mod_surf_para
554	USE indice_sol_mod
555
556	#ifdef CPP_MPI
557	INCLUDE 'mpif.h'
558	#endif
559
560	! Input arguments
561	!****************************************************************************************
562	INTEGER, INTENT(IN) :: knon
563	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
564	REAL, DIMENSION(klon), INTENT(IN) :: pctsrf
565
566	! Output arguments
567	!****************************************************************************************
568	INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours
569
570	! Local variables
571	!****************************************************************************************
572	INTEGER :: i, igrid, jj, ij, iglob
573	INTEGER :: ierr, ireal, index
574	INTEGER, DIMENSION(8,3) :: off_ini
575	INTEGER, DIMENSION(8) :: offset
576	INTEGER, DIMENSION(nbp_lon,nbp_lat) :: correspond
577	INTEGER, DIMENSION(knon_glo) :: ktindex_glo
578	INTEGER, DIMENSION(knon_glo,8) :: neighbours_glo
579	REAL, DIMENSION(klon_glo) :: pctsrf_glo
580	INTEGER :: ktindex(klon)
581	!
582	! End definition
583	!****************************************************************************************
584
585	ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1
586
587	CALL gather_surf(ktindex(1:knon),ktindex_glo)
588	CALL gather(pctsrf,pctsrf_glo)
589
590	IF (is_mpi_root .AND. is_omp_root) THEN
591	neighbours_glo(:,:)=-1
592	! Initialisation des offset
593	!
594	! offset bord ouest
595	off_ini(1,1) = - nbp_lon ; off_ini(2,1) = - nbp_lon + 1 ; off_ini(3,1) = 1
596	off_ini(4,1) = nbp_lon + 1 ; off_ini(5,1) = nbp_lon ; off_ini(6,1) = 2 * nbp_lon - 1
597	off_ini(7,1) = nbp_lon -1 ; off_ini(8,1) = - 1
598	! offset point normal
599	off_ini(1,2) = - nbp_lon ; off_ini(2,2) = - nbp_lon + 1 ; off_ini(3,2) = 1
600	off_ini(4,2) = nbp_lon + 1 ; off_ini(5,2) = nbp_lon ; off_ini(6,2) = nbp_lon - 1
601	off_ini(7,2) = -1 ; off_ini(8,2) = - nbp_lon - 1
602	! offset bord est
603	off_ini(1,3) = - nbp_lon ; off_ini(2,3) = - 2 * nbp_lon + 1 ; off_ini(3,3) = - nbp_lon + 1
604	off_ini(4,3) = 1 ; off_ini(5,3) = nbp_lon ; off_ini(6,3) = nbp_lon - 1
605	off_ini(7,3) = -1 ; off_ini(8,3) = - nbp_lon - 1
606	!
607	!
608	! Attention aux poles
609	!
610	DO igrid = 1, knon_glo
611	index = ktindex_glo(igrid)
612	jj = INT((index - 1)/nbp_lon) + 1
613	ij = index - (jj - 1) * nbp_lon
614	correspond(ij,jj) = igrid
615	ENDDO
616	!sonia : Les mailles des voisines doivent etre toutes egales (pour couplage orchidee)
617	IF (knon_glo == 1) THEN
618	igrid = 1
619	DO i = 1,8
620	neighbours_glo(igrid, i) = igrid
621	ENDDO
622	ELSE
623	print*,'sonia : knon_glo,ij,jj', knon_glo, ij,jj
624
625	DO igrid = 1, knon_glo
626	iglob = ktindex_glo(igrid)
627
628	IF (MOD(iglob, nbp_lon) == 1) THEN
629	offset = off_ini(:,1)
630	ELSE IF(MOD(iglob, nbp_lon) == 0) THEN
631	offset = off_ini(:,3)
632	ELSE
633	offset = off_ini(:,2)
634	ENDIF
635
636	DO i = 1, 8
637	index = iglob + offset(i)
638	ireal = (MIN(MAX(1, index - nbp_lon + 1), klon_glo))
639	IF (pctsrf_glo(ireal) > EPSFRA) THEN
640	jj = INT((index - 1)/nbp_lon) + 1
641	ij = index - (jj - 1) * nbp_lon
642	neighbours_glo(igrid, i) = correspond(ij, jj)
643	ENDIF
644	ENDDO
645	ENDDO
646	ENDIF !fin knon_glo == 1
647
648	ENDIF
649
650	DO i = 1, 8
651	CALL scatter_surf(neighbours_glo(:,i),neighbours(1:knon,i))
652	ENDDO
653	END SUBROUTINE Init_neighbours
654
655	!
656	!****************************************************************************************
657	!
658	#endif
659	END MODULE surf_land_orchidee_mod

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

Download in other formats:

Original Format