My Project
 All Classes Files Functions Variables Macros
surf_land_orchidee_noopenmp_mod.F90
Go to the documentation of this file.
1 !
2 ! $Header$
3 !
4 MODULE 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 
32 CONTAINS
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 :: var_tmp
658  INTEGER, DIMENSION(0:mpi_size-1) :: knon_nb
659  INTEGER, DIMENSION(0:mpi_size-1) :: displs
660  INTEGER, DIMENSION(8,3) :: off_ini
661  INTEGER, DIMENSION(8) :: offset
662  INTEGER, DIMENSION(knon) :: ktindex_p
663  INTEGER, DIMENSION(iim,jjm+1) :: correspond
664  INTEGER, ALLOCATABLE, DIMENSION(:) :: ktindex_g
665  INTEGER, ALLOCATABLE, DIMENSION(:,:) :: neighbours_g
666  REAL, DIMENSION(klon_glo) :: pctsrf_g
667 
668 !
669 ! End definition
670 !****************************************************************************************
671 
672  IF (is_sequential) THEN
673  knon_nb(:)=knon
674  ELSE
675 
676 #ifdef CPP_MPI
677  CALL mpi_gather(knon,1,mpi_integer,knon_nb,1,mpi_integer,0,comm_lmdz_phy,ierr)
678 #endif
679 
680  ENDIF
681 
682  IF (is_mpi_root) THEN
683  knon_g=sum(knon_nb(:))
684  ALLOCATE(ktindex_g(knon_g))
685  ALLOCATE(neighbours_g(knon_g,8))
686  neighbours_g(:,:)=-1
687  displs(0)=0
688  DO i=1,mpi_size-1
689  displs(i)=displs(i-1)+knon_nb(i-1)
690  ENDDO
691  ELSE
692  ALLOCATE(neighbours_g(1,8))
693  ENDIF
694 
695  ktindex_p(1:knon)=ktindex(1:knon)+klon_mpi_begin-1+iim-1
696 
697  IF (is_sequential) THEN
698  ktindex_g(:)=ktindex_p(:)
699  ELSE
700 
701 #ifdef CPP_MPI
702  CALL mpi_gatherv(ktindex_p,knon,mpi_integer,ktindex_g,knon_nb,&
703  displs,mpi_integer,0,comm_lmdz_phy,ierr)
704 #endif
705 
706  ENDIF
707 
708  CALL gather(pctsrf,pctsrf_g)
709 
710  IF (is_mpi_root) THEN
711 ! Initialisation des offset
712 !
713 ! offset bord ouest
714  off_ini(1,1) = - iim ; off_ini(2,1) = - iim + 1; off_ini(3,1) = 1
715  off_ini(4,1) = iim + 1; off_ini(5,1) = iim ; off_ini(6,1) = 2 * iim - 1
716  off_ini(7,1) = iim -1 ; off_ini(8,1) = - 1
717 ! offset point normal
718  off_ini(1,2) = - iim ; off_ini(2,2) = - iim + 1; off_ini(3,2) = 1
719  off_ini(4,2) = iim + 1; off_ini(5,2) = iim ; off_ini(6,2) = iim - 1
720  off_ini(7,2) = -1 ; off_ini(8,2) = - iim - 1
721 ! offset bord est
722  off_ini(1,3) = - iim; off_ini(2,3) = - 2 * iim + 1; off_ini(3,3) = - iim + 1
723  off_ini(4,3) = 1 ; off_ini(5,3) = iim ; off_ini(6,3) = iim - 1
724  off_ini(7,3) = -1 ; off_ini(8,3) = - iim - 1
725 !
726 !
727 ! Attention aux poles
728 !
729  DO igrid = 1, knon_g
730  index = ktindex_g(igrid)
731  jj = int((index - 1)/iim) + 1
732  ij = index - (jj - 1) * iim
733  correspond(ij,jj) = igrid
734  ENDDO
735 
736  DO igrid = 1, knon_g
737  iglob = ktindex_g(igrid)
738  IF (mod(iglob, iim) == 1) THEN
739  offset = off_ini(:,1)
740  ELSE IF(mod(iglob, iim) == 0) THEN
741  offset = off_ini(:,3)
742  ELSE
743  offset = off_ini(:,2)
744  ENDIF
745  DO i = 1, 8
746  index = iglob + offset(i)
747  ireal = (min(max(1, index - iim + 1), klon_glo))
748  IF (pctsrf_g(ireal) > epsfra) THEN
749  jj = int((index - 1)/iim) + 1
750  ij = index - (jj - 1) * iim
751  neighbours_g(igrid, i) = correspond(ij, jj)
752  ENDIF
753  ENDDO
754  ENDDO
755 
756  ENDIF
757 
758  DO i=1,8
759  IF (is_sequential) THEN
760  neighbours(:,i)=neighbours_g(:,i)
761  ELSE
762 #ifdef CPP_MPI
763  IF (knon > 0) THEN
764  ! knon>0, scattter global field neighbours_g from master process to local process
765  CALL mpi_scatterv(neighbours_g(:,i),knon_nb,displs,mpi_integer,neighbours(:,i),knon,mpi_integer,0,comm_lmdz_phy,ierr)
766  ELSE
767  ! knon=0, no need to save the field for this process
768  CALL mpi_scatterv(neighbours_g(:,i),knon_nb,displs,mpi_integer,var_tmp,knon,mpi_integer,0,comm_lmdz_phy,ierr)
769  END IF
770 #endif
771  ENDIF
772  ENDDO
773 
774  END SUBROUTINE init_neighbours
775 !
776 !****************************************************************************************
777 !
778 
779 #endif
780 END MODULE surf_land_orchidee_noopenmp_mod