source: LMDZ5/branches/IPSLCM6.0.8/libf/phylmd/surf_land_orchidee_mod.F90 @ 3046

Last change on this file since 3046 was 2594, checked in by Laurent Fairhead, 8 years ago

Merged trunk changes r2545:2589 into testing branch

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