GCC Code Coverage Report


Directory: ./
File: phys/surf_land_orchidee_mod.f90
Date: 2022-01-11 19:19:34
Exec Total Coverage
Lines: 0 280 0.0%
Branches: 0 414 0.0%

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