Context Navigation

interface_icosa_lmdz.f90 @ 3852

Last change on this file since 3852 was 3852, checked in by ymipsl, 10 years ago

Redonddant point on the frontier domain are not transfered any more from DYNAMICO to LMDZ

File size: 22.7 KB

Line
1	MODULE interface_icosa_lmdz_mod
2
3	USE field_mod, ONLY: t_field
4	USE transfert_mod, ONLY: t_message
5
6
7	TYPE(t_message),SAVE :: req_u
8	TYPE(t_message),SAVE :: req_dps0, req_dulon0, req_dulat0, req_dTemp0, req_dq0
9
10	TYPE(t_field),POINTER,SAVE :: f_p(:)
11	TYPE(t_field),POINTER,SAVE :: f_pks(:)
12	TYPE(t_field),POINTER,SAVE :: f_pk(:)
13	TYPE(t_field),POINTER,SAVE :: f_p_layer(:)
14	TYPE(t_field),POINTER,SAVE :: f_theta(:)
15	TYPE(t_field),POINTER,SAVE :: f_phi(:)
16	TYPE(t_field),POINTER,SAVE :: f_Temp(:)
17	TYPE(t_field),POINTER,SAVE :: f_ulon(:)
18	TYPE(t_field),POINTER,SAVE :: f_ulat(:)
19	TYPE(t_field),POINTER,SAVE :: f_dulon(:)
20	TYPE(t_field),POINTER,SAVE :: f_dulat(:)
21	TYPE(t_field),POINTER,SAVE :: f_dTemp(:)
22	TYPE(t_field),POINTER,SAVE :: f_dq(:)
23	TYPE(t_field),POINTER,SAVE :: f_dps(:)
24	TYPE(t_field),POINTER,SAVE :: f_duc(:)
25	TYPE(t_field),POINTER,SAVE :: f_bounds_lon(:)
26	TYPE(t_field),POINTER,SAVE :: f_bounds_lat(:)
27
28	INTEGER :: start_clock
29	INTEGER :: stop_clock
30	INTEGER :: count_clock=0
31
32	REAL :: day_length
33
34
35	INTEGER,SAVE :: nbp_phys
36	INTEGER,SAVE :: nbp_phys_glo
37
38
39	CONTAINS
40
41	SUBROUTINE initialize_physics
42	USE distrib_icosa_lmdz_mod, ONLY : init_distrib_icosa_lmdz, transfer_icosa_to_lmdz
43	! from dynamico
44	USE domain_mod
45	USE dimensions
46	USE mpi_mod
47	USE mpipara
48	USE disvert_mod
49	USE xios_mod
50	USE time_mod , init_time_icosa=> init_time
51	USE transfert_mod
52
53	! from LMDZ
54	USE mod_grid_phy_lmdz, ONLY : unstructured
55	USE mod_phys_lmdz_omp_data, ONLY: klon_omp
56	USE time_phylmdz_mod, ONLY: init_time_lmdz => init_time
57	USE transfert_mod
58	USE physics_distribution_mod, ONLY : init_physics_distribution
59	USE geometry_mod, ONLY : init_geometry
60	USE vertical_layers_mod, ONLY : init_vertical_layers
61	USE infotrac_phy, ONLY : init_infotrac_phy
62	USE inifis_mod, ONLY : inifis
63	USE phyaqua_mod, ONLY : iniaqua
64
65
66	IMPLICIT NONE
67	INTEGER :: ind,i,j,ij,pos
68	REAL(rstd),POINTER :: bounds_lon(:,:)
69	REAL(rstd),POINTER :: bounds_lat(:,:)
70
71	REAL(rstd),ALLOCATABLE :: latfi(:)
72	REAL(rstd),ALLOCATABLE :: lonfi(:)
73	REAL(rstd),ALLOCATABLE :: airefi(:)
74	REAL(rstd),ALLOCATABLE :: bounds_latfi(:,:)
75	REAL(rstd),ALLOCATABLE :: bounds_lonfi(:,:)
76	REAL(rstd) :: pseudoalt(llm)
77
78	INTEGER :: run_length
79	INTEGER :: annee_ref
80	INTEGER :: day_ref
81	INTEGER :: day_ini
82	REAL :: start_time
83	REAL :: physics_timestep
84
85
86	INTEGER :: nqo, nbtr
87	CHARACTER(len=4) :: type_trac
88	CHARACTER(len=20),ALLOCATABLE :: tname(:) ! tracer short name for restart and diagnostics
89	CHARACTER(len=23),ALLOCATABLE :: ttext(:) ! tracer long name for diagnostics
90	INTEGER,ALLOCATABLE :: niadv(:) ! equivalent dyn / physique
91	INTEGER,ALLOCATABLE :: conv_flg(:) ! conv_flg(it)=0 : convection desactivated for tracer number it
92	INTEGER,ALLOCATABLE :: pbl_flg(:) ! pbl_flg(it)=0 : boundary layer diffusion desactivaded for tracer number it
93	CHARACTER(len=8),ALLOCATABLE :: solsym(:) ! tracer name from inca
94
95	INTEGER :: iflag_phys
96	INTEGER :: nbp_phys, nbp_phys_glo
97
98	!$OMP PARALLEL
99	CALL allocate_field(f_bounds_lon,field_t,type_real,6)
100	CALL allocate_field(f_bounds_lat,field_t,type_real,6)
101	CALL allocate_field(f_p,field_t,type_real,llm+1)
102	CALL allocate_field(f_pks,field_t,type_real)
103	CALL allocate_field(f_pk,field_t,type_real,llm)
104	CALL allocate_field(f_p_layer,field_t,type_real,llm)
105	CALL allocate_field(f_theta,field_t,type_real,llm)
106	CALL allocate_field(f_phi,field_t,type_real,llm)
107	CALL allocate_field(f_Temp,field_t,type_real,llm)
108	CALL allocate_field(f_ulon,field_t,type_real,llm)
109	CALL allocate_field(f_ulat,field_t,type_real,llm)
110	CALL allocate_field(f_dulon,field_t,type_real,llm)
111	CALL allocate_field(f_dulat,field_t,type_real,llm)
112	CALL allocate_field(f_dTemp,field_t,type_real,llm)
113	CALL allocate_field(f_dq,field_t,type_real,llm,nqtot)
114	CALL allocate_field(f_dps,field_t,type_real)
115	CALL allocate_field(f_duc,field_t,type_real,3,llm)
116
117	CALL init_message(f_dps,req_i0,req_dps0)
118	CALL init_message(f_dulon,req_i0,req_dulon0)
119	CALL init_message(f_dulat,req_i0,req_dulat0)
120	CALL init_message(f_dTemp,req_i0,req_dTemp0)
121	CALL init_message(f_dq,req_i0,req_dq0)
122	!$OMP END PARALLEL
123
124	nbp_phys=0
125	DO ind=1,ndomain
126	CALL swap_dimensions(ind)
127	DO j=jj_begin,jj_end
128	DO i=ii_begin,ii_end
129	IF (domain(ind)%own(i,j)) nbp_phys=nbp_phys+1
130	ENDDO
131	ENDDO
132	ENDDO
133
134
135	!initialize LMDZ5 physic mpi decomposition
136	CALL MPI_ALLREDUCE(nbp_phys,nbp_phys_glo,1,MPI_INTEGER,MPI_SUM,comm_icosa,ierr)
137	CALL init_physics_distribution(unstructured, 6, nbp_phys, 1, nbp_phys_glo, llm, comm_icosa)
138
139	DO ind=1,ndomain
140	CALL swap_dimensions(ind)
141	CALL swap_geometry(ind)
142	bounds_lon=f_bounds_lon(ind)
143	bounds_lat=f_bounds_lat(ind)
144	DO j=jj_begin,jj_end
145	DO i=ii_begin,ii_end
146	ij=(j-1)*iim+i
147	CALL xyz2lonlat(xyz_v(ij+z_rup,:), bounds_lon(ij,1), bounds_lat(ij,1))
148	CALL xyz2lonlat(xyz_v(ij+z_up,:), bounds_lon(ij,2), bounds_lat(ij,2))
149	CALL xyz2lonlat(xyz_v(ij+z_lup,:), bounds_lon(ij,3), bounds_lat(ij,3))
150	CALL xyz2lonlat(xyz_v(ij+z_ldown,:), bounds_lon(ij,4), bounds_lat(ij,4))
151	CALL xyz2lonlat(xyz_v(ij+z_down,:), bounds_lon(ij,5), bounds_lat(ij,5))
152	CALL xyz2lonlat(xyz_v(ij+z_rdown,:), bounds_lon(ij,6), bounds_lat(ij,6))
153	ENDDO
154	ENDDO
155	ENDDO
156
157	!$OMP PARALLEL
158	CALL initialize_physics_omp
159	!$OMP END PARALLEL
160
161	CALL xios_set_context
162
163
164
165
166	END SUBROUTINE initialize_physics
167
168
169	SUBROUTINE initialize_physics_omp
170	USE distrib_icosa_lmdz_mod, ONLY : init_distrib_icosa_lmdz, transfer_icosa_to_lmdz
171	! from dynamico
172	USE domain_mod
173	USE dimensions
174	USE mpi_mod
175	USE mpipara
176	USE disvert_mod
177	USE xios_mod
178	USE time_mod , init_time_icosa=> init_time
179
180	! from LMDZ
181	USE mod_grid_phy_lmdz, ONLY : unstructured
182	USE mod_phys_lmdz_omp_data, ONLY: klon_omp
183	USE time_phylmdz_mod, ONLY: init_time_lmdz => init_time
184	USE transfert_mod
185	USE physics_distribution_mod, ONLY : init_physics_distribution
186	USE geometry_mod, ONLY : init_geometry
187	USE vertical_layers_mod, ONLY : init_vertical_layers
188	USE infotrac_phy, ONLY : init_infotrac_phy
189	USE inifis_mod, ONLY : inifis
190	USE phyaqua_mod, ONLY : iniaqua
191
192
193	IMPLICIT NONE
194
195
196
197	INTEGER :: ind,i,j,ij,pos
198	REAL(rstd),POINTER :: bounds_lon(:,:)
199	REAL(rstd),POINTER :: bounds_lat(:,:)
200
201	REAL(rstd),ALLOCATABLE :: latfi(:)
202	REAL(rstd),ALLOCATABLE :: lonfi(:)
203	REAL(rstd),ALLOCATABLE :: airefi(:)
204	REAL(rstd),ALLOCATABLE :: bounds_latfi(:,:)
205	REAL(rstd),ALLOCATABLE :: bounds_lonfi(:,:)
206	REAL(rstd) :: pseudoalt(llm)
207
208	INTEGER :: run_length
209	INTEGER :: annee_ref
210	INTEGER :: day_ref
211	INTEGER :: day_ini
212	REAL :: start_time
213	REAL :: physics_timestep
214
215
216	INTEGER :: nqo, nbtr
217	CHARACTER(len=4) :: type_trac
218	CHARACTER(len=20),ALLOCATABLE :: tname(:) ! tracer short name for restart and diagnostics
219	CHARACTER(len=23),ALLOCATABLE :: ttext(:) ! tracer long name for diagnostics
220	INTEGER,ALLOCATABLE :: niadv(:) ! equivalent dyn / physique
221	INTEGER,ALLOCATABLE :: conv_flg(:) ! conv_flg(it)=0 : convection desactivated for tracer number it
222	INTEGER,ALLOCATABLE :: pbl_flg(:) ! pbl_flg(it)=0 : boundary layer diffusion desactivaded for tracer number it
223	CHARACTER(len=8),ALLOCATABLE :: solsym(:) ! tracer name from inca
224
225	INTEGER :: iflag_phys
226
227
228	CALL init_distrib_icosa_lmdz
229
230	ALLOCATE(latfi(klon_omp))
231	ALLOCATE(lonfi(klon_omp))
232	ALLOCATE(airefi(klon_omp))
233	ALLOCATE(bounds_latfi(klon_omp,6))
234	ALLOCATE(bounds_lonfi(klon_omp,6))
235
236	CALL transfer_icosa_to_lmdz(geom%lat_i,latfi)
237	CALL transfer_icosa_to_lmdz(geom%lon_i,lonfi)
238	CALL transfer_icosa_to_lmdz(f_bounds_lat,bounds_latfi)
239	CALL transfer_icosa_to_lmdz(f_bounds_lon,bounds_lonfi)
240	CALL transfer_icosa_to_lmdz(geom%Ai,airefi)
241
242	CALL init_geometry(lonfi, latfi, bounds_lonfi, bounds_latfi, airefi)
243
244	pseudoalt(:)=0
245	CALL init_vertical_layers(llm,preff,ap,bp,presnivs,pseudoalt)
246
247
248	! Initialize tracer names, numbers, etc. for physics
249
250	!Config Key = type_trac
251	!Config Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
252	!Config Def = lmdz
253	!Config Help =
254	!Config 'lmdz' = pas de couplage, pur LMDZ
255	!Config 'inca' = model de chime INCA
256	!Config 'repr' = model de chime REPROBUS
257	type_trac = 'lmdz'
258	CALL getin('type_trac',type_trac)
259
260	! init model for standard lmdz case
261	nqo=2
262	nbtr=2
263	ALLOCATE(tname(nqtot))
264	ALLOCATE(ttext(nqtot))
265	ALLOCATE(niadv(nqtot))
266	ALLOCATE(conv_flg(nbtr))
267	ALLOCATE(pbl_flg(nbtr))
268	ALLOCATE(solsym(nbtr))
269
270	conv_flg(:) = 1 ! convection activated for all tracers
271	pbl_flg(:) = 1 ! boundary layer activated for all tracers
272	tname(1)='H2Ov'
273	tname(2)='H2Ol'
274	tname(3)='RN'
275	tname(4)='PB'
276	ttext(1)='H2OvVLH'
277	ttext(2)='H2OlVL1'
278	ttext(3)='RNVL1'
279	ttext(4)='PBVL1'
280	solsym(1:2)=tname(3:4)
281	niadv(1)=1
282	niadv(2)=2
283	niadv(3)=3
284	niadv(4)=4
285
286	CALL init_infotrac_phy(nqtot,nqo,nbtr,tname,ttext,type_trac,&
287	niadv,conv_flg,pbl_flg,solsym)
288
289	! Initialize physical constant
290	day_length=86400
291	CALL getin('day_length',day_length)
292	CALL inifis(day_length,radius,g,kappa*cpp,cpp)
293
294
295
296	! init time
297	annee_ref=2015
298	CALL getin("anneeref",annee_ref)
299
300	day_ref=1
301	CALL getin("dayref",day_ref)
302
303	physics_timestep=dt*itau_physics
304	run_length=itaumax*dt
305	ndays=NINT(run_length/day_length)
306
307	day_ini=INT(itau0*dt/day_length)+day_ref
308	start_time= itau0dt/day_length-INT(itau0dt/day_length)
309
310	CALL init_time_lmdz(annee_ref, day_ref, day_ini, start_time, ndays, physics_timestep)
311
312	! Additional initializations for aquaplanets
313	CALL getin("iflag_phys",iflag_phys)
314	IF (iflag_phys>=100) THEN
315	CALL iniaqua(klon_omp, iflag_phys)
316	END IF
317
318
319	END SUBROUTINE initialize_physics_omp
320
321
322
323
324	SUBROUTINE physics
325	USE ICOSA
326	USE time_mod
327	USE disvert_mod
328	USE transfert_mod
329	USE mpipara
330	USE xios_mod
331	USE trace
332	USE distrib_icosa_lmdz_mod, ONLY : transfer_icosa_to_lmdz, transfer_lmdz_to_icosa
333	USE physics_external_mod, ONLY : it, f_phis, f_ps, f_theta_rhodz, f_u, f_wflux, f_q
334	! from LMDZ
335	USE mod_phys_lmdz_omp_data, ONLY: klon_omp
336	IMPLICIT NONE
337
338	REAL(rstd),POINTER :: phis(:)
339	REAL(rstd),POINTER :: ps(:)
340	REAL(rstd),POINTER :: theta_rhodz(:,:)
341	REAL(rstd),POINTER :: u(:,:)
342	REAL(rstd),POINTER :: wflux(:,:)
343	REAL(rstd),POINTER :: q(:,:,:)
344	REAL(rstd),POINTER :: p(:,:)
345	REAL(rstd),POINTER :: pks(:)
346	REAL(rstd),POINTER :: pk(:,:)
347	REAL(rstd),POINTER :: p_layer(:,:)
348	REAL(rstd),POINTER :: theta(:,:)
349	REAL(rstd),POINTER :: phi(:,:)
350	REAL(rstd),POINTER :: Temp(:,:)
351	REAL(rstd),POINTER :: ulon(:,:)
352	REAL(rstd),POINTER :: ulat(:,:)
353	REAL(rstd),POINTER :: dulon(:,:)
354	REAL(rstd),POINTER :: dulat(:,:)
355	REAL(rstd),POINTER :: dTemp(:,:)
356	REAL(rstd),POINTER :: dq(:,:,:)
357	REAL(rstd),POINTER :: dps(:)
358	REAL(rstd),POINTER :: duc(:,:,:)
359
360
361	INTEGER :: ind
362
363	REAL(rstd),ALLOCATABLE,SAVE :: ps_phy(:)
364	!$OMP THREADPRIVATE(ps_phy)
365	REAL(rstd),ALLOCATABLE,SAVE :: p_phy(:,:)
366	!$OMP THREADPRIVATE(p_phy)
367	REAL(rstd),ALLOCATABLE,SAVE :: p_layer_phy(:,:)
368	!$OMP THREADPRIVATE(p_layer_phy)
369	REAL(rstd),ALLOCATABLE,SAVE :: Temp_phy(:,:)
370	!$OMP THREADPRIVATE(Temp_phy)
371	REAL(rstd),ALLOCATABLE,SAVE :: phis_phy(:)
372	!$OMP THREADPRIVATE(phis_phy)
373	REAL(rstd),ALLOCATABLE,SAVE :: phi_phy(:,:)
374	!$OMP THREADPRIVATE(phi_phy)
375	REAL(rstd),ALLOCATABLE,SAVE :: ulon_phy(:,:)
376	!$OMP THREADPRIVATE(ulon_phy)
377	REAL(rstd),ALLOCATABLE,SAVE :: ulat_phy(:,:)
378	!$OMP THREADPRIVATE(ulat_phy)
379	REAL(rstd),ALLOCATABLE,SAVE :: q_phy(:,:,:)
380	!$OMP THREADPRIVATE(q_phy)
381	REAL(rstd),ALLOCATABLE,SAVE :: wflux_phy(:,:)
382	!$OMP THREADPRIVATE(wflux_phy)
383	REAL(rstd),ALLOCATABLE,SAVE :: dulon_phy(:,:)
384	!$OMP THREADPRIVATE(dulon_phy)
385	REAL(rstd),ALLOCATABLE,SAVE :: dulat_phy(:,:)
386	!$OMP THREADPRIVATE(dulat_phy)
387	REAL(rstd),ALLOCATABLE,SAVE :: dTemp_phy(:,:)
388	!$OMP THREADPRIVATE(dTemp_phy)
389	REAL(rstd),ALLOCATABLE,SAVE :: dq_phy(:,:,:)
390	!$OMP THREADPRIVATE(dq_phy)
391	REAL(rstd),ALLOCATABLE,SAVE :: dps_phy(:)
392	!$OMP THREADPRIVATE(dps_phy)
393	REAL(rstd) :: dtphy
394	LOGICAL :: debut
395	LOGICAL :: lafin
396	LOGICAL,SAVE :: first=.TRUE.
397	!$OMP THREADPRIVATE(first)
398
399
400	IF(first) THEN
401	debut=.TRUE.
402	ELSE
403	debut=.FALSE.
404	ENDIF
405
406
407	IF(it-itau0>=itaumax) THEN
408	lafin=.TRUE.
409	ELSE
410	lafin=.FALSE.
411	ENDIF
412
413	IF (first) THEN
414	first=.FALSE.
415	CALL init_message(f_u,req_e1_vect,req_u)
416	ALLOCATE(ps_phy(klon_omp))
417	ALLOCATE(p_phy(klon_omp,llm+1))
418	ALLOCATE(p_layer_phy(klon_omp,llm))
419	ALLOCATE(Temp_phy(klon_omp,llm))
420	ALLOCATE(phis_phy(klon_omp))
421	ALLOCATE(phi_phy(klon_omp,llm))
422	ALLOCATE(ulon_phy(klon_omp,llm))
423	ALLOCATE(ulat_phy(klon_omp,llm))
424	ALLOCATE(q_phy(klon_omp,llm,nqtot))
425	ALLOCATE(wflux_phy(klon_omp,llm))
426	ALLOCATE(dulon_phy(klon_omp,llm))
427	ALLOCATE(dulat_phy(klon_omp,llm))
428	ALLOCATE(dTemp_phy(klon_omp,llm))
429	ALLOCATE(dq_phy(klon_omp,llm,nqtot))
430	ALLOCATE(dps_phy(klon_omp))
431	!$OMP BARRIER
432	ENDIF
433
434
435	!$OMP MASTER
436	! CALL update_calendar(it)
437	!$OMP END MASTER
438	!$OMP BARRIER
439	dtphy=itau_physics*dt
440
441
442
443	CALL transfert_message(f_u,req_u)
444
445	DO ind=1,ndomain
446	CALL swap_dimensions(ind)
447	IF (assigned_domain(ind)) THEN
448	CALL swap_geometry(ind)
449
450	phis=f_phis(ind)
451	ps=f_ps(ind)
452	theta_rhodz=f_theta_rhodz(ind)
453	u=f_u(ind)
454	q=f_q(ind)
455	wflux=f_wflux(ind)
456	p=f_p(ind)
457	pks=f_pks(ind)
458	pk=f_pk(ind)
459	p_layer=f_p_layer(ind)
460	theta=f_theta(ind)
461	phi=f_phi(ind)
462	Temp=f_Temp(ind)
463	ulon=f_ulon(ind)
464	ulat=f_ulat(ind)
465
466	CALL grid_icosa_to_physics
467
468	ENDIF
469	ENDDO
470
471	!$OMP BARRIER
472	!$OMP MASTER
473	CALL SYSTEM_CLOCK(start_clock)
474	!$OMP END MASTER
475	CALL trace_start("physic")
476	! CALL trace_off()
477
478
479
480	CALL transfer_icosa_to_lmdz(f_p , p_phy)
481	CALL transfer_icosa_to_lmdz(f_p_layer, p_layer_phy)
482	CALL transfer_icosa_to_lmdz(f_phi , phi_phy)
483	CALL transfer_icosa_to_lmdz(f_phis , phis_phy )
484	CALL transfer_icosa_to_lmdz(f_ulon , ulon_phy )
485	CALL transfer_icosa_to_lmdz(f_ulat , ulat_phy)
486	CALL transfer_icosa_to_lmdz(f_Temp , Temp_phy)
487	CALL transfer_icosa_to_lmdz(f_q , q_phy)
488	CALL transfer_icosa_to_lmdz(f_wflux , wflux_phy)
489
490
491	CALL physiq(klon_omp, llm, debut, lafin, dtphy, &
492	p_phy, p_layer_phy, phi_phy, phis_phy, presnivs, ulon_phy, ulat_phy, Temp_phy, q_phy, wflux_phy, &
493	dulon_phy, dulat_phy, dTemp_phy, dq_phy, dps_phy)
494
495	CALL transfer_lmdz_to_icosa(dulon_phy, f_dulon )
496	CALL transfer_lmdz_to_icosa(dulat_phy, f_dulat )
497	CALL transfer_lmdz_to_icosa(dTemp_phy, f_dTemp )
498	CALL transfer_lmdz_to_icosa(dq_phy , f_dq )
499	CALL transfer_lmdz_to_icosa(dps_phy , f_dps )
500
501	CALL send_message(f_dps,req_dps0)
502	CALL send_message(f_dulon,req_dulon0)
503	CALL send_message(f_dulat,req_dulat0)
504	CALL send_message(f_dTemp,req_dTemp0)
505	CALL send_message(f_dq,req_dq0)
506
507	CALL wait_message(req_dps0)
508	CALL wait_message(req_dulon0)
509	CALL wait_message(req_dulat0)
510	CALL wait_message(req_dTemp0)
511	CALL wait_message(req_dq0)
512
513
514	! CALL trace_on()
515	CALL trace_end("physic")
516	!$OMP MASTER
517	CALL SYSTEM_CLOCK(stop_clock)
518	count_clock=count_clock+stop_clock-start_clock
519	!$OMP END MASTER
520
521	!$OMP BARRIER
522
523	DO ind=1,ndomain
524	CALL swap_dimensions(ind)
525	IF (assigned_domain(ind)) THEN
526	CALL swap_geometry(ind)
527
528	theta_rhodz=f_theta_rhodz(ind)
529	u=f_u(ind)
530	q=f_q(ind)
531	ps=f_ps(ind)
532	dulon=f_dulon(ind)
533	dulat=f_dulat(ind)
534	Temp=f_temp(ind)
535	dTemp=f_dTemp(ind)
536	dq=f_dq(ind)
537	dps=f_dps(ind)
538	duc=f_duc(ind)
539	p=f_p(ind)
540	pks=f_pks(ind)
541	pk=f_pk(ind)
542
543	CALL grid_physics_to_icosa
544	ENDIF
545	ENDDO
546
547	!$OMP BARRIER
548	CALL xios_set_context
549
550
551	CONTAINS
552
553	SUBROUTINE grid_icosa_to_physics
554	USE pression_mod
555	USE exner_mod
556	USE theta2theta_rhodz_mod
557	USE geopotential_mod
558	USE wind_mod
559	USE omp_para
560	IMPLICIT NONE
561
562	REAL(rstd) :: uc(3)
563	INTEGER :: i,j,ij,l
564
565
566	! compute pression
567
568	DO l = ll_begin,ll_endp1
569	DO j=jj_begin,jj_end
570	DO i=ii_begin,ii_end
571	ij=(j-1)*iim+i
572	p(ij,l) = ap(l) + bp(l) * ps(ij)
573	ENDDO
574	ENDDO
575	ENDDO
576
577	!$OMP BARRIER
578
579	! compute exner
580
581	IF (is_omp_first_level) THEN
582	DO j=jj_begin,jj_end
583	DO i=ii_begin,ii_end
584	ij=(j-1)*iim+i
585	pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
586	ENDDO
587	ENDDO
588	ENDIF
589
590	! 3D : pk
591	DO l = ll_begin,ll_end
592	DO j=jj_begin,jj_end
593	DO i=ii_begin,ii_end
594	ij=(j-1)*iim+i
595	pk(ij,l) = cpp * ((.5/preff)(p(ij,l)+p(ij,l+1))) * kappa
596	ENDDO
597	ENDDO
598	ENDDO
599
600	!$OMP BARRIER
601
602	! compute theta, temperature and pression at layer
603	DO l = ll_begin, ll_end
604	DO j=jj_begin,jj_end
605	DO i=ii_begin,ii_end
606	ij=(j-1)*iim+i
607	theta(ij,l) = theta_rhodz(ij,l) / ((p(ij,l)-p(ij,l+1))/g)
608	Temp(ij,l) = theta(ij,l) * pk(ij,l) / cpp
609	p_layer(ij,l)=preff(pk(ij,l)/cpp)*(1./kappa)
610	ENDDO
611	ENDDO
612	ENDDO
613
614
615	!!! Compute geopotential
616
617	! for first layer
618	IF (is_omp_first_level) THEN
619	DO j=jj_begin,jj_end
620	DO i=ii_begin,ii_end
621	ij=(j-1)*iim+i
622	phi( ij,1 ) = phis( ij ) + theta(ij,1) * ( pks(ij) - pk(ij,1) )
623	ENDDO
624	ENDDO
625	ENDIF
626	!!-> implicit flush on phi(:,1)
627
628	! for other layers
629	DO l = ll_beginp1, ll_end
630	DO j=jj_begin,jj_end
631	DO i=ii_begin,ii_end
632	ij=(j-1)*iim+i
633	phi(ij,l) = 0.5 * ( theta(ij,l) + theta(ij,l-1) ) &
634	* ( pk(ij,l-1) - pk(ij,l) )
635	ENDDO
636	ENDDO
637	ENDDO
638
639	!$OMP BARRIER
640
641
642	IF (is_omp_first_level) THEN
643	DO l = 2, llm
644	DO j=jj_begin,jj_end
645	! ---> Bug compilo intel ici en openmp
646	! ---> Couper la boucle
647	IF (j==jj_end+1) PRINT*,"this message must not be printed"
648	DO i=ii_begin,ii_end
649	ij=(j-1)*iim+i
650	phi(ij,l) = phi(ij,l)+ phi(ij,l-1)
651	ENDDO
652	ENDDO
653	ENDDO
654	! --> IMPLICIT FLUSH on phi --> non
655	ENDIF
656
657	! compute wind centered lon lat compound
658	DO l=ll_begin,ll_end
659	DO j=jj_begin,jj_end
660	DO i=ii_begin,ii_end
661	ij=(j-1)*iim+i
662	uc(:)=1/Ai(ij)* &
663	( ne(ij,right)u(ij+u_right,l)le(ij+u_right)*((xyz_v(ij+z_rdown,:)+xyz_v(ij+z_rup,:))/2-centroid(ij,:)) &
664	+ ne(ij,rup)u(ij+u_rup,l)le(ij+u_rup)*((xyz_v(ij+z_rup,:)+xyz_v(ij+z_up,:))/2-centroid(ij,:)) &
665	+ ne(ij,lup)u(ij+u_lup,l)le(ij+u_lup)*((xyz_v(ij+z_up,:)+xyz_v(ij+z_lup,:))/2-centroid(ij,:)) &
666	+ ne(ij,left)u(ij+u_left,l)le(ij+u_left)*((xyz_v(ij+z_lup,:)+xyz_v(ij+z_ldown,:))/2-centroid(ij,:)) &
667	+ ne(ij,ldown)u(ij+u_ldown,l)le(ij+u_ldown)*((xyz_v(ij+z_ldown,:)+xyz_v(ij+z_down,:))/2-centroid(ij,:))&
668	+ ne(ij,rdown)u(ij+u_rdown,l)le(ij+u_rdown)*((xyz_v(ij+z_down,:)+xyz_v(ij+z_rdown,:))/2-centroid(ij,:)))
669	ulon(ij,l)=sum(uc(:)*elon_i(ij,:))
670	ulat(ij,l)=sum(uc(:)*elat_i(ij,:))
671	ENDDO
672	ENDDO
673	ENDDO
674
675	!$OMP BARRIER
676	END SUBROUTINE grid_icosa_to_physics
677
678
679	SUBROUTINE grid_physics_to_icosa
680	USE theta2theta_rhodz_mod
681	USE omp_para
682	IMPLICIT NONE
683	INTEGER :: i,j,ij,l,iq
684
685	DO l=ll_begin,ll_end
686	DO j=jj_begin,jj_end
687	DO i=ii_begin,ii_end
688	ij=(j-1)*iim+i
689	duc(ij,:,l)=dulon(ij,l)elon_i(ij,:)+dulat(ij,l)elat_i(ij,:)
690	ENDDO
691	ENDDO
692	ENDDO
693
694	DO l=ll_begin,ll_end
695	DO j=jj_begin,jj_end
696	DO i=ii_begin,ii_end
697	ij=(j-1)*iim+i
698	u(ij+u_right,l) = u(ij+u_right,l) + dtphy * sum( 0.5(duc(ij,:,l) + duc(ij+t_right,:,l))ep_e(ij+u_right,:) )
699	u(ij+u_lup,l) = u(ij+u_lup,l) + dtphy * sum( 0.5(duc(ij,:,l) + duc(ij+t_lup,:,l))ep_e(ij+u_lup,:) )
700	u(ij+u_ldown,l) = u(ij+u_ldown,l) + dtphysum( 0.5(duc(ij,:,l) + duc(ij+t_ldown,:,l))*ep_e(ij+u_ldown,:) )
701	ENDDO
702	ENDDO
703	ENDDO
704
705	DO l=ll_begin,ll_end
706	DO j=jj_begin,jj_end
707	DO i=ii_begin,ii_end
708	ij=(j-1)*iim+i
709	Temp(ij,l)=Temp(ij,l)+ dtphy * dTemp(ij,l)
710	ENDDO
711	ENDDO
712	ENDDO
713
714	DO iq=1,nqtot
715	DO l=ll_begin,ll_end
716	DO j=jj_begin,jj_end
717	DO i=ii_begin,ii_end
718	ij=(j-1)*iim+i
719	q(ij,l,iq)=q(ij,l,iq)+ dtphy * dq(ij,l,iq)
720	ENDDO
721	ENDDO
722	ENDDO
723	ENDDO
724
725	!$OMP BARRIER
726
727	IF (is_omp_first_level) THEN
728	DO j=jj_begin,jj_end
729	DO i=ii_begin,ii_end
730	ij=(j-1)*iim+i
731	ps(ij)=ps(ij)+ dtphy * dps(ij)
732	ENDDO
733	ENDDO
734	ENDIF
735
736	! CALL compute_temperature2theta_rhodz(ps,Temp,theta_rhodz,0)
737
738	! compute pression
739	!$OMP BARRIER
740	DO l = ll_begin,ll_endp1
741	DO j=jj_begin,jj_end
742	DO i=ii_begin,ii_end
743	ij=(j-1)*iim+i
744	p(ij,l) = ap(l) + bp(l) * ps(ij)
745	ENDDO
746	ENDDO
747	ENDDO
748
749	!$OMP BARRIER
750
751	! compute exner
752
753	IF (is_omp_first_level) THEN
754	DO j=jj_begin,jj_end
755	DO i=ii_begin,ii_end
756	ij=(j-1)*iim+i
757	pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
758	ENDDO
759	ENDDO
760	ENDIF
761
762	! 3D : pk
763	DO l = ll_begin,ll_end
764	DO j=jj_begin,jj_end
765	DO i=ii_begin,ii_end
766	ij=(j-1)*iim+i
767	pk(ij,l) = cpp * ((.5/preff)(p(ij,l)+p(ij,l+1))) * kappa
768	ENDDO
769	ENDDO
770	ENDDO
771
772	!$OMP BARRIER
773
774	! compute theta, temperature and pression at layer
775	DO l = ll_begin, ll_end
776	DO j=jj_begin,jj_end
777	DO i=ii_begin,ii_end
778	ij=(j-1)*iim+i
779	theta_rhodz(ij,l) = temp(ij,l) * ((p(ij,l)-p(ij,l+1))/g) / (pk(ij,l) / cpp )
780	ENDDO
781	ENDDO
782	ENDDO
783
784	END SUBROUTINE grid_physics_to_icosa
785
786
787
788	END SUBROUTINE physics
789
790
791
792
793
794	END MODULE interface_icosa_lmdz_mod

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

Download in other formats:

Original Format