Context Navigation

surf_land_orchidee_mod.F90 @ 5926

Last change on this file since 5926 was 5894, checked in by Sebastien Nguyen, 2 weeks ago
rephase LMDZISO with 5864 version of phylmd + bug fixes in physiq_mod + other bugs in isoverif sections. Code now compiles and runs with -debug -isotopes true -isoverif. There are still isoverif error messages for Dexcess getting greater than 1000 on some points at some moments.
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: 30.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	#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	IF (klon_glo == 1) THEN
378	lon_scat(:,1) = rlon_g(1)
379	lat_scat(:,1) = rlat_g(1)
380	lon_scat(:,nbp_lat) = rlon_g(1)
381	lat_scat(:,nbp_lat) = rlat_g(klon_glo)
382	ELSE!FC
383	DO jj = 2, nbp_lat-1
384	DO ij = 1, nbp_lon
385	index = index + 1
386	lon_scat(ij,jj) = rlon_g(index)
387	lat_scat(ij,jj) = rlat_g(index)
388	ENDDO
389	ENDDO
390	lon_scat(:,1) = lon_scat(:,2)
391	lat_scat(:,1) = rlat_g(1)
392	lon_scat(:,nbp_lat) = lon_scat(:,2)
393	lat_scat(:,nbp_lat) = rlat_g(klon_glo)
394	ENDIF !FC
395
396	ENDIF
397
398	CALL bcast(lon_scat)
399	CALL bcast(lat_scat)
400
401	ENDIF
402	!
403	! Allouer et initialiser le tableau des voisins et des fraction de continents
404	!
405	IF (( .NOT. ALLOCATED(contfrac))) THEN
406	ALLOCATE(contfrac(knon), stat = error)
407	IF (error /= 0) THEN
408	abort_message='Pb allocation contfrac'
409	CALL abort_physic(modname,abort_message,1)
410	ENDIF
411	ENDIF
412
413	DO igrid = 1, knon
414	ireal = knindex(igrid)
415	contfrac(igrid) = pctsrf(ireal,is_ter)
416	ENDDO
417
418
419	IF (grid_type==regular_lonlat) THEN
420
421	IF ( (.NOT.ALLOCATED(neighbours))) THEN
422	ALLOCATE(neighbours(knon,8), stat = error)
423	IF (error /= 0) THEN
424	abort_message='Pb allocation neighbours'
425	CALL abort_physic(modname,abort_message,1)
426	ENDIF
427	ENDIF
428	neighbours = -1.
429	CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter))
430
431	ELSE IF (grid_type==unstructured) THEN
432
433	IF ( (.NOT.ALLOCATED(neighbours))) THEN
434	ALLOCATE(neighbours(knon,12), stat = error)
435	IF (error /= 0) THEN
436	abort_message='Pb allocation neighbours'
437	CALL abort_physic(modname,abort_message,1)
438	ENDIF
439	ENDIF
440	neighbours = -1.
441
442	ENDIF
443
444
445	!
446	! Allocation et calcul resolutions
447	IF ( (.NOT.ALLOCATED(resolution))) THEN
448	ALLOCATE(resolution(knon,2), stat = error)
449	IF (error /= 0) THEN
450	abort_message='Pb allocation resolution'
451	CALL abort_physic(modname,abort_message,1)
452	ENDIF
453	ENDIF
454
455	IF (grid_type==regular_lonlat) THEN
456	DO igrid = 1, knon
457	ij = knindex(igrid)
458	resolution(igrid,1) = dx(ij)
459	resolution(igrid,2) = dy(ij)
460	print*, 'resolution FCCC',resolution(igrid,1),resolution(igrid,2)
461	ENDDO
462	ENDIF
463
464	ALLOCATE(coastalflow(klon), stat = error)
465	IF (error /= 0) THEN
466	abort_message='Pb allocation coastalflow'
467	CALL abort_physic(modname,abort_message,1)
468	ENDIF
469
470	ALLOCATE(riverflow(klon), stat = error)
471	IF (error /= 0) THEN
472	abort_message='Pb allocation riverflow'
473	CALL abort_physic(modname,abort_message,1)
474	ENDIF
475	!
476	! carbon_cycle_cpl not possible with this interface and version of ORHCHIDEE
477	!
478	! >> PC
479	! IF (carbon_cycle_cpl) THEN
480	! abort_message='carbon_cycle_cpl not yet possible with this interface of ORCHIDEE'
481	! CALL abort_physic(modname,abort_message,1)
482	! END IF
483	! << PC
484
485	ENDIF ! (fin debut)
486
487	!
488	! Appel a la routine sols continentaux
489	!
490	IF (lafin) lrestart_write = .TRUE.
491	IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write
492
493	petA_orc(1:knon) = petBcoef(1:knon) * dtime
494	petB_orc(1:knon) = petAcoef(1:knon)
495	peqA_orc(1:knon) = peqBcoef(1:knon) * dtime
496	peqB_orc(1:knon) = peqAcoef(1:knon)
497
498	cdrag = 0.
499	cdrag(1:knon) = tq_cdrag(1:knon)
500
501	! zlev(1:knon) = (100.plev(1:knon))/((ps(1:knon)/287.05temp_air(1:knon))*9.80665)
502	! zlev(1:knon) = (100.plev(1:knon))/((ps(1:knon)/RDtemp_air(1:knon))*RG)
503	zlev(1:knon) = plev(1:knon)RDtemp_air(1:knon)/((ps(1:knon)100.0)RG)
504
505
506	! PF et PASB
507	! where(cdrag > 0.01)
508	! cdrag = 0.01
509	! endwhere
510	! write(,)'Cdrag = ',minval(cdrag),maxval(cdrag)
511
512
513	IF (debut) THEN
514	CALL Init_orchidee_index(knon,knindex,offset,ktindex)
515	CALL Get_orchidee_communicator(orch_comm,orch_mpi_size,orch_mpi_rank, orch_omp_size,orch_omp_rank)
516
517	IF (grid_type==unstructured) THEN
518	IF (knon==0) THEN
519	begin=1
520	end=0
521	ELSE
522	begin=offset+1
523	end=offset+ktindex(knon)
524	ENDIF
525
526	IF (orch_mpi_rank==orch_mpi_size-1 .AND. orch_omp_rank==orch_omp_size-1) end=nbp_lon*nbp_lat
527
528	ALLOCATE(lalo(end-begin+1,2))
529	ALLOCATE(bounds_lalo(end-begin+1,nvertex,2))
530	ALLOCATE(ind_cell(end-begin+1))
531
532	ALLOCATE(longitude_glo(klon_glo))
533	CALL gather(longitude,longitude_glo)
534	CALL bcast(longitude_glo)
535	lalo(:,2)=longitude_glo(begin:end)*180./PI
536
537	ALLOCATE(latitude_glo(klon_glo))
538	CALL gather(latitude,latitude_glo)
539	CALL bcast(latitude_glo)
540	lalo(:,1)=latitude_glo(begin:end)*180./PI
541
542	ALLOCATE(boundslon_glo(klon_glo,nvertex))
543	CALL gather(boundslon,boundslon_glo)
544	CALL bcast(boundslon_glo)
545	bounds_lalo(:,:,2)=boundslon_glo(begin:end,:)*180./PI
546
547	ALLOCATE(boundslat_glo(klon_glo,nvertex))
548	CALL gather(boundslat,boundslat_glo)
549	CALL bcast(boundslat_glo)
550	bounds_lalo(:,:,1)=boundslat_glo(begin:end,:)*180./PI
551
552	ALLOCATE(ind_cell_glo_glo(klon_glo))
553	CALL gather(ind_cell_glo,ind_cell_glo_glo)
554	CALL bcast(ind_cell_glo_glo)
555	ind_cell(:)=ind_cell_glo_glo(begin:end)
556
557	ENDIF
558	CALL Init_synchro_omp
559
560	!$OMP BARRIER
561
562	IF (knon > 0) THEN
563	#ifdef CPP_VEGET
564	CALL Init_intersurf(nbp_lon,nbp_lat,knon,ktindex,offset,orch_omp_size,orch_omp_rank,orch_comm,grid=grid_type)
565	#endif
566	ENDIF
567
568	CALL Synchro_omp
569
570
571	IF (knon > 0) THEN
572
573	#ifdef CPP_VEGET
574
575	CALL intersurf_initialize_gathered (itime+itau_phy-1, nbp_lon, nbp_lat, knon, ktindex, dtime, &
576	lrestart_read, lrestart_write, lalo, contfrac, neighbours, resolution, date0, &
577	zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, &
578	cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
579	precip_rain, precip_snow, lwdown, swnet, swdown, ps, &
580	evap, fluxsens, fluxlat, coastalflow, riverflow, &
581	tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0m_new, &
582	lon_scat, lat_scat, q2m(1:knon), t2m(1:knon), z0h_new(1:knon), nvm_orch, &
583	grid=grid_type, bounds_latlon=bounds_lalo, cell_area=area, ind_cell_glo=ind_cell, &
584	field_out_names=cfname_out, field_in_names=cfname_in(1:nbcf_in_orc), &
585	coszang=yrmu0(1:knon))
586	#endif
587	ENDIF
588
589	CALL Synchro_omp
590
591	albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
592
593	ENDIF
594
595	! swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon))
596	swdown_vrai(1:knon) = swdown(1:knon)
597	!$OMP BARRIER
598
599	IF (knon > 0) THEN
600	#ifdef CPP_VEGET
601	IF (nvm_orch .NE. nvm_lmdz ) THEN
602	abort_message='Pb de dimensiosn PFT: nvm_orch et nvm_lmdz differents.'
603	CALL abort_physic(modname,abort_message,1)
604	ENDIF
605
606	CALL intersurf_main_gathered (itime+itau_phy, nbp_lon, nbp_lat, knon, ktindex, dtime, &
607	lrestart_read, lrestart_write, lalo, &
608	contfrac, neighbours, resolution, date0, &
609	zlev, u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
610	cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
611	precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), &
612	evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
613	tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0m_new(1:knon), &
614	lon_scat, lat_scat, q2m(1:knon), t2m(1:knon), z0h_new(1:knon),&
615	veget(1:knon,:),lai(1:knon,:),height(1:knon,:),&
616	fields_out=yfields_out(1:knon,1:nbcf_out), &
617	fields_in=yfields_in(1:knon,1:nbcf_in_orc), &
618	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))
619	#endif
620	ENDIF
621
622	CALL Synchro_omp
623
624	albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
625
626	!* Send to coupler
627	!
628	IF (type_ocean=='couple') THEN
629	CALL cpl_send_land_fields(itime, knon, knindex, &
630	riverflow, coastalflow)
631	IF (landice_opt .GE. 2) THEN
632	CALL cpl_send_landice_fields(itime, knon, knindex, run_off_lic, run_off_lic_frac)
633	END IF
634	ENDIF
635
636	alb1_new(1:knon) = albedo_out(1:knon,1)
637	alb2_new(1:knon) = albedo_out(1:knon,2)
638
639	! Convention orchidee: positif vers le haut
640	fluxsens(1:knon) = -1. * fluxsens(1:knon)
641	fluxlat(1:knon) = -1. * fluxlat(1:knon)
642
643	! evap = -1. * evap
644
645	IF (debut) lrestart_read = .FALSE.
646
647	IF (debut) CALL Finalize_surf_para
648
649	! >> PC
650	! Decompressing variables into LMDz for the module carbon_cycle_mod
651	! nbcf_in can be zero, in which case the loop does not operate
652	! fields_in can then used elsewhere in the model
653
654	fields_in(:,:)=0.0
655
656	DO nb=1, nbcf_in_orc
657	DO igrid = 1, knon
658	ireal = knindex(igrid)
659	fields_in(ireal,nb)=yfields_in(igrid,nb)
660	ENDDO
661	WRITE(,) 'surf_land_orchidee_mod --- yfields_in :',cfname_in(nb)
662	ENDDO
663	! >> PC
664
665	END SUBROUTINE surf_land_orchidee
666	!
667	!****************************************************************************************
668	!
669	SUBROUTINE Init_orchidee_index(knon,knindex,offset,ktindex)
670	USE mod_surf_para
671	USE mod_grid_phy_lmdz
672
673	INTEGER,INTENT(IN) :: knon
674	INTEGER,INTENT(IN) :: knindex(klon)
675	INTEGER,INTENT(OUT) :: offset
676	INTEGER,INTENT(OUT) :: ktindex(klon)
677
678	INTEGER :: ktindex_glo(knon_glo)
679	INTEGER :: offset_para(0:omp_size*mpi_size-1)
680	INTEGER :: LastPoint
681	INTEGER :: task
682
683	ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1
684
685	CALL gather_surf(ktindex(1:knon),ktindex_glo)
686
687	IF (is_mpi_root .AND. is_omp_root) THEN
688	LastPoint=0
689	DO Task=0,mpi_size*omp_size-1
690	IF (knon_glo_para(Task)>0) THEN
691	offset_para(task)= LastPoint-MOD(LastPoint,nbp_lon)
692	LastPoint=ktindex_glo(knon_glo_end_para(task))
693	ENDIF
694	ENDDO
695	ENDIF
696
697	CALL bcast(offset_para)
698
699	offset=offset_para(omp_size*mpi_rank+omp_rank)
700
701	ktindex(1:knon)=ktindex(1:knon)-offset
702
703	END SUBROUTINE Init_orchidee_index
704
705	!
706	!*********************** *************************************************************
707	!
708
709	SUBROUTINE Get_orchidee_communicator(orch_comm, orch_mpi_size, orch_mpi_rank, orch_omp_size,orch_omp_rank)
710	USE mod_surf_para
711	USE lmdz_mpi
712
713	INTEGER,INTENT(OUT) :: orch_comm
714	INTEGER,INTENT(OUT) :: orch_mpi_size
715	INTEGER,INTENT(OUT) :: orch_mpi_rank
716	INTEGER,INTENT(OUT) :: orch_omp_size
717	INTEGER,INTENT(OUT) :: orch_omp_rank
718	INTEGER :: color
719	INTEGER :: i,ierr
720	!
721	! End definition
722	!****************************************************************************************
723
724	IF (is_omp_root) THEN
725
726	IF (knon_mpi==0) THEN
727	color = 0
728	ELSE
729	color = 1
730	ENDIF
731
732	IF (using_mpi) THEN
733	CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr)
734	CALL MPI_COMM_SIZE(orch_comm,orch_mpi_size,ierr)
735	CALL MPI_COMM_RANK(orch_comm,orch_mpi_rank,ierr)
736	ENDIF
737
738	ENDIF
739	CALL bcast_omp(orch_comm)
740
741	IF (knon_mpi /= 0) THEN
742	orch_omp_size=0
743	DO i=0,omp_size-1
744	IF (knon_omp_para(i) /=0) THEN
745	orch_omp_size=orch_omp_size+1
746	IF (i==omp_rank) orch_omp_rank=orch_omp_size-1
747	ENDIF
748	ENDDO
749	ENDIF
750
751	END SUBROUTINE Get_orchidee_communicator
752	!
753	!****************************************************************************************
754	!
755
756	SUBROUTINE Init_neighbours(knon,neighbours,knindex,pctsrf)
757	USE mod_grid_phy_lmdz
758	USE mod_surf_para
759	USE indice_sol_mod
760	USE lmdz_mpi
761
762	! Input arguments
763	!****************************************************************************************
764	INTEGER, INTENT(IN) :: knon
765	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
766	REAL, DIMENSION(klon), INTENT(IN) :: pctsrf
767
768	! Output arguments
769	!****************************************************************************************
770	INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours
771
772	! Local variables
773	!****************************************************************************************
774	INTEGER :: i, igrid, jj, ij, iglob
775	INTEGER :: ierr, ireal, index
776	INTEGER, DIMENSION(8,3) :: off_ini
777	INTEGER, DIMENSION(8) :: offset
778	INTEGER, DIMENSION(nbp_lon,nbp_lat) :: correspond
779	INTEGER, DIMENSION(knon_glo) :: ktindex_glo
780	INTEGER, DIMENSION(knon_glo,8) :: neighbours_glo
781	REAL, DIMENSION(klon_glo) :: pctsrf_glo
782	INTEGER :: ktindex(klon)
783	!
784	! End definition
785	!****************************************************************************************
786
787	ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1
788
789	CALL gather_surf(ktindex(1:knon),ktindex_glo)
790	CALL gather(pctsrf,pctsrf_glo)
791
792	IF (is_mpi_root .AND. is_omp_root) THEN
793	neighbours_glo(:,:)=-1
794	! Initialisation des offset
795	!
796	! offset bord ouest
797	off_ini(1,1) = - nbp_lon ; off_ini(2,1) = - nbp_lon + 1 ; off_ini(3,1) = 1
798	off_ini(4,1) = nbp_lon + 1 ; off_ini(5,1) = nbp_lon ; off_ini(6,1) = 2 * nbp_lon - 1
799	off_ini(7,1) = nbp_lon -1 ; off_ini(8,1) = - 1
800	! offset point normal
801	off_ini(1,2) = - nbp_lon ; off_ini(2,2) = - nbp_lon + 1 ; off_ini(3,2) = 1
802	off_ini(4,2) = nbp_lon + 1 ; off_ini(5,2) = nbp_lon ; off_ini(6,2) = nbp_lon - 1
803	off_ini(7,2) = -1 ; off_ini(8,2) = - nbp_lon - 1
804	! offset bord est
805	off_ini(1,3) = - nbp_lon ; off_ini(2,3) = - 2 * nbp_lon + 1 ; off_ini(3,3) = - nbp_lon + 1
806	off_ini(4,3) = 1 ; off_ini(5,3) = nbp_lon ; off_ini(6,3) = nbp_lon - 1
807	off_ini(7,3) = -1 ; off_ini(8,3) = - nbp_lon - 1
808	!
809	! Attention aux poles
810	!
811	DO igrid = 1, knon_glo
812	index = ktindex_glo(igrid)
813	jj = INT((index - 1)/nbp_lon) + 1
814	ij = index - (jj - 1) * nbp_lon
815	correspond(ij,jj) = igrid
816	ENDDO
817	!sonia : Les mailles des voisines doivent etre toutes egales (pour couplage orchidee)
818	IF (knon_glo == 1) THEN
819	igrid = 1
820	DO i = 1,8
821	neighbours_glo(igrid, i) = igrid
822	ENDDO
823	ELSE
824
825	DO igrid = 1, knon_glo
826	iglob = ktindex_glo(igrid)
827
828	IF (MOD(iglob, nbp_lon) == 1) THEN
829	offset = off_ini(:,1)
830	ELSE IF(MOD(iglob, nbp_lon) == 0) THEN
831	offset = off_ini(:,3)
832	ELSE
833	offset = off_ini(:,2)
834	ENDIF
835
836	DO i = 1, 8
837	index = iglob + offset(i)
838	ireal = (MIN(MAX(1, index - nbp_lon + 1), klon_glo))
839	IF (pctsrf_glo(ireal) > EPSFRA) THEN
840	jj = INT((index - 1)/nbp_lon) + 1
841	ij = index - (jj - 1) * nbp_lon
842	neighbours_glo(igrid, i) = correspond(ij, jj)
843	ENDIF
844	ENDDO
845	ENDDO
846	ENDIF !fin knon_glo == 1
847
848	ENDIF
849
850	DO i = 1, 8
851	CALL scatter_surf(neighbours_glo(:,i),neighbours(1:knon,i))
852	ENDDO
853	END SUBROUTINE Init_neighbours
854
855	!
856	!****************************************************************************************
857	!
858	#endif
859	#endif
860	#endif
861	#endif
862	#endif
863	END MODULE surf_land_orchidee_mod

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

Download in other formats:

Original Format