source: LMDZ5/trunk/libf/phylmd/surf_land_orchidee_mod.F90 @ 2311

Last change on this file since 2311 was 2311, checked in by Ehouarn Millour, 9 years ago

Further modifications to enforce physics/dynamics separation:

  • moved iniprint.h and misc_mod back to dyn3d_common, as these should only be used by dynamics.
  • created print_control_mod in the physics to store flags prt_level, lunout, debug to be local to physics (should be used rather than iniprint.h)
  • created abort_physic.F90 , which does the same job as abort_gcm() did, but should be used instead when in physics.
  • reactivated inifis (turned it into a module, inifis_mod.F90) to initialize physical constants and print_control_mod flags.

EM

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