Context Navigation

surf_land_orchidee_mod.F90 @ 5308

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

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

Download in other formats:

Original Format