source: LMDZ5/trunk/libf/phylmd/surf_land_orchidee_noopenmp_mod.F90 @ 1454

Last change on this file since 1454 was 1454, checked in by Laurent Fairhead, 14 years ago

Merge of LMDZ5V1.0-dev branch r1453 into LMDZ5 trunk r1434


Fusion entre la version r1453 de la branche de développement LMDZ5V1.0-dev
et le tronc LMDZ5 (r1434)

File size: 26.1 KB
Line 
1!
2! $Header$
3!
4MODULE surf_land_orchidee_noopenmp_mod
5!
6! This module is compiled only if CPP key ORCHIDEE_NOOPENMP is defined.
7! This module should be used with ORCHIDEE sequentiel or parallele MPI version (not MPI-OpenMP mixte)
8
9#ifdef ORCHIDEE_NOOPENMP
10!
11! This module controles the interface towards the model ORCHIDEE
12!
13! Subroutines in this module : surf_land_orchidee
14!                              Init_orchidee_index
15!                              Get_orchidee_communicator
16!                              Init_neighbours
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 comgeomphy,   ONLY : cuphy, cvphy
24  USE mod_grid_phy_lmdz
25  USE mod_phys_lmdz_para
26
27  IMPLICIT NONE
28
29  PRIVATE
30  PUBLIC  :: surf_land_orchidee
31
32CONTAINS
33!
34!****************************************************************************************
35
36  SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, &
37       knindex, rlon, rlat, pctsrf, &
38       debut, lafin, &
39       plev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, &
40       tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
41       precip_rain, precip_snow, lwdown, swnet, swdown, &
42       ps, q2m, t2m, &
43       evap, fluxsens, fluxlat, &             
44       tsol_rad, tsurf_new, alb1_new, alb2_new, &
45       emis_new, z0_new, qsurf)
46!   
47! Cette routine sert d'interface entre le modele atmospherique et le
48! modele de sol continental. Appel a sechiba
49!
50! L. Fairhead 02/2000
51!
52! input:
53!   itime        numero du pas de temps
54!   dtime        pas de temps de la physique (en s)
55!   nisurf       index de la surface a traiter (1 = sol continental)
56!   knon         nombre de points de la surface a traiter
57!   knindex      index des points de la surface a traiter
58!   rlon         longitudes de la grille entiere
59!   rlat         latitudes de la grille entiere
60!   pctsrf       tableau des fractions de surface de chaque maille
61!   debut        logical: 1er appel a la physique (lire les restart)
62!   lafin        logical: dernier appel a la physique (ecrire les restart)
63!                     (si false calcul simplifie des fluxs sur les continents)
64!   plev         hauteur de la premiere couche (Pa)     
65!   u1_lay       vitesse u 1ere couche
66!   v1_lay       vitesse v 1ere couche
67!   temp_air     temperature de l'air 1ere couche
68!   spechum      humidite specifique 1ere couche
69!   epot_air     temp pot de l'air
70!   ccanopy      concentration CO2 canopee, correspond au co2_send de
71!                carbon_cycle_mod ou valeur constant co2_ppm
72!   tq_cdrag     cdrag
73!   petAcoef     coeff. A de la resolution de la CL pour t
74!   peqAcoef     coeff. A de la resolution de la CL pour q
75!   petBcoef     coeff. B de la resolution de la CL pour t
76!   peqBcoef     coeff. B de la resolution de la CL pour q
77!   precip_rain  precipitation liquide
78!   precip_snow  precipitation solide
79!   lwdown       flux IR descendant a la surface
80!   swnet        flux solaire net
81!   swdown       flux solaire entrant a la surface
82!   ps           pression au sol
83!   radsol       rayonnement net aus sol (LW + SW)
84!   
85!
86! output:
87!   evap         evaporation totale
88!   fluxsens     flux de chaleur sensible
89!   fluxlat      flux de chaleur latente
90!   tsol_rad     
91!   tsurf_new    temperature au sol
92!   alb1_new     albedo in visible SW interval
93!   alb2_new     albedo in near IR interval
94!   emis_new     emissivite
95!   z0_new       surface roughness
96!   qsurf        air moisture at surface
97!
98    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, fco2_land_inst, fco2_lu_inst
99    IMPLICIT NONE
100
101    INCLUDE "indicesol.h"
102    INCLUDE "temps.h"
103    INCLUDE "YOMCST.h"
104    INCLUDE "iniprint.h"
105    INCLUDE "dimensions.h"
106 
107!
108! Parametres d'entree
109!****************************************************************************************
110    INTEGER, INTENT(IN)                       :: itime
111    REAL, INTENT(IN)                          :: dtime
112    REAL, INTENT(IN)                          :: date0
113    INTEGER, INTENT(IN)                       :: knon
114    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
115    LOGICAL, INTENT(IN)                       :: debut, lafin
116    REAL, DIMENSION(klon,nbsrf), INTENT(IN)   :: pctsrf
117    REAL, DIMENSION(klon), INTENT(IN)         :: rlon, rlat
118    REAL, DIMENSION(klon), INTENT(IN)         :: plev
119    REAL, DIMENSION(klon), INTENT(IN)         :: u1_lay, v1_lay
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, z0_new
135
136! Local
137!****************************************************************************************
138    INTEGER                                   :: ij, jj, igrid, ireal, index
139    INTEGER                                   :: error
140    INTEGER, SAVE                             :: nb_fields_cpl ! number of fields for the climate-carbon coupling (between ATM and ORCHIDEE).
141    REAL, SAVE, ALLOCATABLE, DIMENSION(:,:)   :: fields_cpl    ! Fluxes for the climate-carbon coupling
142    REAL, DIMENSION(klon)                     :: swdown_vrai
143    CHARACTER (len = 20)                      :: modname = 'surf_land_orchidee'
144    CHARACTER (len = 80)                      :: abort_message
145    LOGICAL,SAVE                              :: check = .FALSE.
146    !$OMP THREADPRIVATE(check)
147
148! type de couplage dans sechiba
149!  character (len=10)   :: coupling = 'implicit'
150! drapeaux controlant les appels dans SECHIBA
151!  type(control_type), save   :: control_in
152! Preserved albedo
153    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: albedo_keep, zlev
154    !$OMP THREADPRIVATE(albedo_keep,zlev)
155! coordonnees geographiques
156    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: lalo
157    !$OMP THREADPRIVATE(lalo)
158! pts voisins
159    INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours
160    !$OMP THREADPRIVATE(neighbours)
161! fractions continents
162    REAL,ALLOCATABLE, DIMENSION(:), SAVE      :: contfrac
163    !$OMP THREADPRIVATE(contfrac)
164! resolution de la grille
165    REAL, ALLOCATABLE, DIMENSION (:,:), SAVE  :: resolution
166    !$OMP THREADPRIVATE(resolution)
167
168    REAL, ALLOCATABLE, DIMENSION (:,:), SAVE  :: lon_scat, lat_scat 
169    !$OMP THREADPRIVATE(lon_scat,lat_scat)
170
171    LOGICAL, SAVE                             :: lrestart_read = .TRUE.
172    !$OMP THREADPRIVATE(lrestart_read)
173    LOGICAL, SAVE                             :: lrestart_write = .FALSE.
174    !$OMP THREADPRIVATE(lrestart_write)
175
176    REAL, DIMENSION(knon,2)                   :: albedo_out
177    !$OMP THREADPRIVATE(albedo_out)
178
179! Pb de nomenclature
180    REAL, DIMENSION(klon)                     :: petA_orc, peqA_orc
181    REAL, DIMENSION(klon)                     :: petB_orc, peqB_orc
182! Pb de correspondances de grilles
183    INTEGER, DIMENSION(:), SAVE, ALLOCATABLE  :: ig, jg
184    !$OMP THREADPRIVATE(ig,jg)
185    INTEGER :: indi, indj
186    INTEGER, SAVE, ALLOCATABLE,DIMENSION(:)   :: ktindex
187    !$OMP THREADPRIVATE(ktindex)
188
189! Essai cdrag
190    REAL, DIMENSION(klon)                     :: cdrag
191    INTEGER,SAVE                              :: offset
192    !$OMP THREADPRIVATE(offset)
193
194    REAL, DIMENSION(klon_glo)                 :: rlon_g,rlat_g
195    INTEGER, SAVE                             :: orch_comm
196    !$OMP THREADPRIVATE(orch_comm)
197
198    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: coastalflow
199    !$OMP THREADPRIVATE(coastalflow)
200    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: riverflow
201    !$OMP THREADPRIVATE(riverflow)
202!
203! Fin definition
204!****************************************************************************************
205#ifdef CPP_VEGET
206
207    IF (check) WRITE(lunout,*)'Entree ', modname
208 
209! Initialisation
210 
211    IF (debut) THEN
212! Test de coherence
213#ifndef ORCH_NEW
214       ! Compilation avec orchidee nouvelle version necessaire avec carbon_cycle_cpl=y
215       IF (carbon_cycle_cpl) THEN
216          abort_message='You must define preprossing key ORCH_NEW when running carbon_cycle_cpl=y'
217          CALL abort_gcm(modname,abort_message,1)
218       END IF
219#endif
220       ALLOCATE(ktindex(knon))
221       IF ( .NOT. ALLOCATED(albedo_keep)) THEN
222          ALLOCATE(albedo_keep(klon))
223          ALLOCATE(zlev(knon))
224       ENDIF
225! Pb de correspondances de grilles
226       ALLOCATE(ig(klon))
227       ALLOCATE(jg(klon))
228       ig(1) = 1
229       jg(1) = 1
230       indi = 0
231       indj = 2
232       DO igrid = 2, klon - 1
233          indi = indi + 1
234          IF ( indi > iim) THEN
235             indi = 1
236             indj = indj + 1
237          ENDIF
238          ig(igrid) = indi
239          jg(igrid) = indj
240       ENDDO
241       ig(klon) = 1
242       jg(klon) = jjm + 1
243
244       IF ((.NOT. ALLOCATED(lalo))) THEN
245          ALLOCATE(lalo(knon,2), stat = error)
246          IF (error /= 0) THEN
247             abort_message='Pb allocation lalo'
248             CALL abort_gcm(modname,abort_message,1)
249          ENDIF
250       ENDIF
251       IF ((.NOT. ALLOCATED(lon_scat))) THEN
252          ALLOCATE(lon_scat(iim,jjm+1), stat = error)
253          IF (error /= 0) THEN
254             abort_message='Pb allocation lon_scat'
255             CALL abort_gcm(modname,abort_message,1)
256          ENDIF
257       ENDIF
258       IF ((.NOT. ALLOCATED(lat_scat))) THEN
259          ALLOCATE(lat_scat(iim,jjm+1), stat = error)
260          IF (error /= 0) THEN
261             abort_message='Pb allocation lat_scat'
262             CALL abort_gcm(modname,abort_message,1)
263          ENDIF
264       ENDIF
265       lon_scat = 0.
266       lat_scat = 0.
267       DO igrid = 1, knon
268          index = knindex(igrid)
269          lalo(igrid,2) = rlon(index)
270          lalo(igrid,1) = rlat(index)
271       ENDDO
272
273       
274       
275       CALL Gather(rlon,rlon_g)
276       CALL Gather(rlat,rlat_g)
277
278       IF (is_mpi_root) THEN
279          index = 1
280          DO jj = 2, jjm
281             DO ij = 1, iim
282                index = index + 1
283                lon_scat(ij,jj) = rlon_g(index)
284                lat_scat(ij,jj) = rlat_g(index)
285             ENDDO
286          ENDDO
287          lon_scat(:,1) = lon_scat(:,2)
288          lat_scat(:,1) = rlat_g(1)
289          lon_scat(:,jjm+1) = lon_scat(:,2)
290          lat_scat(:,jjm+1) = rlat_g(klon_glo)
291       ENDIF
292
293       CALL bcast(lon_scat)
294       CALL bcast(lat_scat)
295
296!
297! Allouer et initialiser le tableau des voisins et des fraction de continents
298!
299       IF ( (.NOT.ALLOCATED(neighbours))) THEN
300          ALLOCATE(neighbours(knon,8), stat = error)
301          IF (error /= 0) THEN
302             abort_message='Pb allocation neighbours'
303             CALL abort_gcm(modname,abort_message,1)
304          ENDIF
305       ENDIF
306       neighbours = -1.
307       IF (( .NOT. ALLOCATED(contfrac))) THEN
308          ALLOCATE(contfrac(knon), stat = error)
309          IF (error /= 0) THEN
310             abort_message='Pb allocation contfrac'
311             CALL abort_gcm(modname,abort_message,1)
312          ENDIF
313       ENDIF
314
315       DO igrid = 1, knon
316          ireal = knindex(igrid)
317          contfrac(igrid) = pctsrf(ireal,is_ter)
318       ENDDO
319
320
321       CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter))
322
323!
324!  Allocation et calcul resolutions
325       IF ( (.NOT.ALLOCATED(resolution))) THEN
326          ALLOCATE(resolution(knon,2), stat = error)
327          IF (error /= 0) THEN
328             abort_message='Pb allocation resolution'
329             CALL abort_gcm(modname,abort_message,1)
330          ENDIF
331       ENDIF
332       DO igrid = 1, knon
333          ij = knindex(igrid)
334          resolution(igrid,1) = cuphy(ij)
335          resolution(igrid,2) = cvphy(ij)
336       ENDDO
337     
338       ALLOCATE(coastalflow(klon), stat = error)
339       IF (error /= 0) THEN
340          abort_message='Pb allocation coastalflow'
341          CALL abort_gcm(modname,abort_message,1)
342       ENDIF
343       
344       ALLOCATE(riverflow(klon), stat = error)
345       IF (error /= 0) THEN
346          abort_message='Pb allocation riverflow'
347          CALL abort_gcm(modname,abort_message,1)
348       ENDIF
349
350!
351! Allocate variables needed for carbon_cycle_mod
352       IF ( carbon_cycle_cpl ) THEN
353          nb_fields_cpl=2
354       ELSE
355          nb_fields_cpl=1
356       END IF
357
358
359       IF (carbon_cycle_cpl) THEN
360          ALLOCATE(fco2_land_inst(klon),stat=error)
361          IF (error /= 0)  CALL abort_gcm(modname,'Pb in allocation fco2_land_inst',1)
362         
363          ALLOCATE(fco2_lu_inst(klon),stat=error)
364          IF(error /=0) CALL abort_gcm(modname,'Pb in allocation fco2_lu_inst',1)
365       END IF
366
367       ALLOCATE(fields_cpl(klon,nb_fields_cpl), stat = error)
368       IF (error /= 0) CALL abort_gcm(modname,'Pb in allocation fields_cpl',1)
369
370    ENDIF                          ! (fin debut)
371
372!
373! Appel a la routine sols continentaux
374!
375    IF (lafin) lrestart_write = .TRUE.
376    IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write
377   
378    petA_orc(1:knon) = petBcoef(1:knon) * dtime
379    petB_orc(1:knon) = petAcoef(1:knon)
380    peqA_orc(1:knon) = peqBcoef(1:knon) * dtime
381    peqB_orc(1:knon) = peqAcoef(1:knon)
382
383    cdrag = 0.
384    cdrag(1:knon) = tq_cdrag(1:knon)
385
386! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/287.05*temp_air(1:knon))*9.80665)
387    zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG)
388
389
390! PF et PASB
391!   where(cdrag > 0.01)
392!     cdrag = 0.01
393!   endwhere
394!  write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag)
395
396!
397! Init Orchidee
398!
399!  if (pole_nord) then
400!    offset=0
401!    ktindex(:)=ktindex(:)+iim-1
402!  else
403!    offset = klon_mpi_begin-1+iim-1
404!    ktindex(:)=ktindex(:)+MOD(offset,iim)
405!    offset=offset-MOD(offset,iim)
406!  endif
407 
408    IF (debut) THEN
409       CALL Get_orchidee_communicator(knon,orch_comm)
410       IF (knon /=0) THEN
411          CALL Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex)
412
413#ifndef CPP_MPI
414          ! Interface for ORCHIDEE compiled in sequential mode(without preprocessing flag CPP_MPI)
415          CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, knon, ktindex, dtime, &
416               lrestart_read, lrestart_write, lalo, &
417               contfrac, neighbours, resolution, date0, &
418               zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
419               cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
420               precip_rain, precip_snow, lwdown, swnet, swdown, ps, &
421               evap, fluxsens, fluxlat, coastalflow, riverflow, &
422               tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
423               lon_scat, lat_scat, q2m, t2m &
424#ifdef ORCH_NEW
425               , nb_fields_cpl, fields_cpl)
426#else
427               )
428#endif
429
430#else         
431          ! Interface for ORCHIDEE version 1.9 or later(1.9.2, 1.9.3, 1.9.4, 1.9.5) compiled in parallel mode(with preprocessing flag CPP_MPI)
432          CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, offset, knon, ktindex, &
433               orch_comm, dtime, lrestart_read, lrestart_write, lalo, &
434               contfrac, neighbours, resolution, date0, &
435               zlev,  u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
436               cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
437               precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown(1:knon), ps(1:knon), &
438               evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
439               tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
440               lon_scat, lat_scat, q2m, t2m &
441#ifdef ORCH_NEW
442               , nb_fields_cpl, fields_cpl(1:knon,:))
443#else
444               )
445#endif
446#endif
447         
448       ENDIF
449
450       albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
451
452    ENDIF
453
454!  swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon))
455    swdown_vrai(1:knon) = swdown(1:knon)
456
457    IF (knon /=0) THEN
458#ifndef CPP_MPI
459       ! Interface for ORCHIDEE compiled in sequential mode(without preprocessing flag CPP_MPI)
460       CALL intersurf_main (itime+itau_phy, iim, jjm+1, knon, ktindex, dtime, &
461            lrestart_read, lrestart_write, lalo, &
462            contfrac, neighbours, resolution, date0, &
463            zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
464            cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
465            precip_rain, precip_snow, lwdown, swnet, swdown_vrai, ps, &
466            evap, fluxsens, fluxlat, coastalflow, riverflow, &
467            tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
468            lon_scat, lat_scat, q2m, t2m &
469#ifdef ORCH_NEW
470            , nb_fields_cpl, fields_cpl)
471#else
472            )
473#endif
474#else
475       ! Interface for ORCHIDEE version 1.9 or later compiled in parallel mode(with preprocessing flag CPP_MPI)
476       CALL intersurf_main (itime+itau_phy, iim, jjm+1,offset, knon, ktindex, &
477            orch_comm,dtime, lrestart_read, lrestart_write, lalo, &
478            contfrac, neighbours, resolution, date0, &
479            zlev,  u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
480            cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
481            precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), &
482            evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
483            tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
484            lon_scat, lat_scat, q2m, t2m &
485#ifdef ORCH_NEW
486            , nb_fields_cpl, fields_cpl(1:knon,:))
487#else
488            )
489#endif
490#endif
491    ENDIF
492
493    albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
494
495!* Send to coupler
496!
497    IF (type_ocean=='couple') THEN
498       CALL cpl_send_land_fields(itime, knon, knindex, &
499            riverflow, coastalflow)
500    ENDIF
501
502    alb1_new(1:knon) = albedo_out(1:knon,1)
503    alb2_new(1:knon) = albedo_out(1:knon,2)
504
505! Convention orchidee: positif vers le haut
506    fluxsens(1:knon) = -1. * fluxsens(1:knon)
507    fluxlat(1:knon)  = -1. * fluxlat(1:knon)
508   
509!  evap     = -1. * evap
510
511    IF (debut) lrestart_read = .FALSE.
512
513! Decompress variables for the module carbon_cycle_mod
514    IF (carbon_cycle_cpl) THEN
515       fco2_land_inst(:)=0.
516       fco2_lu_inst(:)=0.
517       
518       DO igrid = 1, knon
519          ireal = knindex(igrid)
520          fco2_land_inst(ireal) = fields_cpl(igrid,1)
521          fco2_lu_inst(ireal)   = fields_cpl(igrid,2)
522       END DO
523    END IF
524
525#endif   
526  END SUBROUTINE surf_land_orchidee
527!
528!****************************************************************************************
529!
530  SUBROUTINE Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex)
531   
532    INCLUDE "dimensions.h"
533
534#ifdef CPP_MPI
535    INCLUDE 'mpif.h'
536#endif   
537
538
539! Input arguments
540!****************************************************************************************
541    INTEGER, INTENT(IN)                   :: knon
542    INTEGER, INTENT(IN)                   :: orch_comm
543    INTEGER, DIMENSION(klon), INTENT(IN)  :: knindex
544
545! Output arguments
546!****************************************************************************************
547    INTEGER, INTENT(OUT)                  :: offset
548    INTEGER, DIMENSION(knon), INTENT(OUT) :: ktindex
549
550! Local varables
551!****************************************************************************************
552#ifdef CPP_MPI
553    INTEGER, DIMENSION(MPI_STATUS_SIZE)   :: status
554#endif
555
556    INTEGER                               :: MyLastPoint
557    INTEGER                               :: LastPoint
558    INTEGER                               :: mpi_rank_orch
559    INTEGER                               :: mpi_size_orch
560    INTEGER                               :: ierr
561!
562! End definition
563!****************************************************************************************
564
565    MyLastPoint=klon_mpi_begin-1+knindex(knon)+iim-1
566   
567    IF (is_parallel) THEN
568#ifdef CPP_MPI   
569       CALL MPI_COMM_SIZE(orch_comm,mpi_size_orch,ierr)
570       CALL MPI_COMM_RANK(orch_comm,mpi_rank_orch,ierr)
571#endif
572    ELSE
573       mpi_rank_orch=0
574       mpi_size_orch=1
575    ENDIF
576
577    IF (is_parallel) THEN
578       IF (mpi_rank_orch /= 0) THEN
579#ifdef CPP_MPI
580          CALL MPI_RECV(LastPoint,1,MPI_INTEGER,mpi_rank_orch-1,1234,orch_comm,status,ierr)
581#endif
582       ENDIF
583       
584       IF (mpi_rank_orch /= mpi_size_orch-1) THEN
585#ifdef CPP_MPI
586          CALL MPI_SEND(MyLastPoint,1,MPI_INTEGER,mpi_rank_orch+1,1234,orch_comm,ierr) 
587#endif
588       ENDIF
589    ENDIF
590   
591    IF (mpi_rank_orch == 0) THEN
592       offset=0
593    ELSE
594       offset=LastPoint-MOD(LastPoint,iim)
595    ENDIF
596   
597    ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin+iim-1)-offset-1     
598   
599
600  END SUBROUTINE  Init_orchidee_index
601!
602!****************************************************************************************
603!
604  SUBROUTINE Get_orchidee_communicator(knon,orch_comm)
605   
606#ifdef CPP_MPI
607    INCLUDE 'mpif.h'
608#endif   
609
610
611    INTEGER,INTENT(IN)  :: knon
612    INTEGER,INTENT(OUT) :: orch_comm
613   
614    INTEGER             :: color
615    INTEGER             :: ierr
616!
617! End definition
618!****************************************************************************************
619
620    IF (knon==0) THEN
621       color = 0
622    ELSE
623       color = 1
624    ENDIF
625   
626#ifdef CPP_MPI   
627    CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr)
628#endif
629   
630  END SUBROUTINE Get_orchidee_communicator
631!
632!****************************************************************************************
633
634  SUBROUTINE Init_neighbours(knon,neighbours,ktindex,pctsrf)
635   
636    INCLUDE "indicesol.h"
637    INCLUDE "dimensions.h"
638#ifdef CPP_MPI
639    INCLUDE 'mpif.h'
640#endif   
641
642! Input arguments
643!****************************************************************************************
644    INTEGER, INTENT(IN)                     :: knon
645    INTEGER, DIMENSION(klon), INTENT(IN)    :: ktindex
646    REAL, DIMENSION(klon), INTENT(IN)       :: pctsrf
647   
648! Output arguments
649!****************************************************************************************
650    INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours
651
652! Local variables
653!****************************************************************************************
654    INTEGER                              :: knon_g
655    INTEGER                              :: i, igrid, jj, ij, iglob
656    INTEGER                              :: ierr, ireal, index
657    INTEGER, DIMENSION(0:mpi_size-1)     :: knon_nb
658    INTEGER, DIMENSION(0:mpi_size-1)     :: displs
659    INTEGER, DIMENSION(8,3)              :: off_ini
660    INTEGER, DIMENSION(8)                :: offset 
661    INTEGER, DIMENSION(knon)             :: ktindex_p
662    INTEGER, DIMENSION(iim,jjm+1)        :: correspond
663    INTEGER, ALLOCATABLE, DIMENSION(:)   :: ktindex_g
664    INTEGER, ALLOCATABLE, DIMENSION(:,:) :: neighbours_g
665    REAL, DIMENSION(klon_glo)            :: pctsrf_g
666   
667!
668! End definition
669!****************************************************************************************
670
671    IF (is_sequential) THEN
672       knon_nb(:)=knon
673    ELSE 
674       
675#ifdef CPP_MPI 
676       CALL MPI_GATHER(knon,1,MPI_INTEGER,knon_nb,1,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
677#endif
678       
679    ENDIF
680   
681    IF (is_mpi_root) THEN
682       knon_g=SUM(knon_nb(:))
683       ALLOCATE(ktindex_g(knon_g))
684       ALLOCATE(neighbours_g(knon_g,8))
685       neighbours_g(:,:)=-1
686       displs(0)=0
687       DO i=1,mpi_size-1
688          displs(i)=displs(i-1)+knon_nb(i-1)
689       ENDDO
690   ELSE
691       ALLOCATE(neighbours_g(1,8))
692   ENDIF
693   
694    ktindex_p(1:knon)=ktindex(1:knon)+klon_mpi_begin-1+iim-1
695   
696    IF (is_sequential) THEN
697       ktindex_g(:)=ktindex_p(:)
698    ELSE
699       
700#ifdef CPP_MPI 
701       CALL MPI_GATHERV(ktindex_p,knon,MPI_INTEGER,ktindex_g,knon_nb,&
702            displs,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
703#endif
704       
705    ENDIF
706   
707    CALL Gather(pctsrf,pctsrf_g)
708   
709    IF (is_mpi_root) THEN
710!  Initialisation des offset   
711!
712! offset bord ouest
713       off_ini(1,1) = - iim  ; off_ini(2,1) = - iim + 1; off_ini(3,1) = 1
714       off_ini(4,1) = iim + 1; off_ini(5,1) = iim      ; off_ini(6,1) = 2 * iim - 1
715       off_ini(7,1) = iim -1 ; off_ini(8,1) = - 1
716! offset point normal
717       off_ini(1,2) = - iim  ; off_ini(2,2) = - iim + 1; off_ini(3,2) = 1
718       off_ini(4,2) = iim + 1; off_ini(5,2) = iim      ; off_ini(6,2) = iim - 1
719       off_ini(7,2) = -1     ; off_ini(8,2) = - iim - 1
720! offset bord   est
721       off_ini(1,3) = - iim; off_ini(2,3) = - 2 * iim + 1; off_ini(3,3) = - iim + 1
722       off_ini(4,3) =  1   ; off_ini(5,3) = iim          ; off_ini(6,3) = iim - 1
723       off_ini(7,3) = -1   ; off_ini(8,3) = - iim - 1
724!
725!
726! Attention aux poles
727!
728       DO igrid = 1, knon_g
729          index = ktindex_g(igrid)
730          jj = INT((index - 1)/iim) + 1
731          ij = index - (jj - 1) * iim
732          correspond(ij,jj) = igrid
733       ENDDO
734       
735       DO igrid = 1, knon_g
736          iglob = ktindex_g(igrid)
737          IF (MOD(iglob, iim) == 1) THEN
738             offset = off_ini(:,1)
739          ELSE IF(MOD(iglob, iim) == 0) THEN
740             offset = off_ini(:,3)
741          ELSE
742             offset = off_ini(:,2)
743          ENDIF
744          DO i = 1, 8
745             index = iglob + offset(i)
746             ireal = (MIN(MAX(1, index - iim + 1), klon_glo))
747             IF (pctsrf_g(ireal) > EPSFRA) THEN
748                jj = INT((index - 1)/iim) + 1
749                ij = index - (jj - 1) * iim
750                neighbours_g(igrid, i) = correspond(ij, jj)
751             ENDIF
752          ENDDO
753       ENDDO
754
755    ENDIF
756   
757    DO i=1,8
758       IF (is_sequential) THEN
759          neighbours(:,i)=neighbours_g(:,i)
760       ELSE
761#ifdef CPP_MPI
762          CALL MPI_SCATTERV(neighbours_g(:,i),knon_nb,displs,MPI_INTEGER,neighbours(:,i),knon,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
763#endif
764       ENDIF
765    ENDDO
766   
767  END SUBROUTINE Init_neighbours
768!
769!****************************************************************************************
770!
771
772#endif
773END MODULE surf_land_orchidee_noopenmp_mod
Note: See TracBrowser for help on using the repository browser.