Context Navigation

surf_land_orchidee_mod.F90 @ 1106

Last change on this file since 1106 was 1067, checked in by Laurent Fairhead, 16 years ago

Modifications lie au premier niveau du modele pour la diffusion turbulent

du vent.

Preparation pour un couplage des courrant oceaniques.

Property svn:eol-style set to native
Property svn:executable set to *
Property svn:keywords set to Author Date Id Revision

File size: 21.1 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format