Context Navigation

interface_icosa_lmdz.f90 @ 3868

Last change on this file since 3868 was 3863, checked in by ymipsl, 9 years ago

Update for LMDZ forced configuration

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 wxios
332	USE trace
333	USE distrib_icosa_lmdz_mod, ONLY : transfer_icosa_to_lmdz, transfer_lmdz_to_icosa
334	USE physics_external_mod, ONLY : it, f_phis, f_ps, f_theta_rhodz, f_u, f_wflux, f_q
335	! from LMDZ
336	USE mod_phys_lmdz_omp_data, ONLY: klon_omp
337	IMPLICIT NONE
338
339	REAL(rstd),POINTER :: phis(:)
340	REAL(rstd),POINTER :: ps(:)
341	REAL(rstd),POINTER :: theta_rhodz(:,:)
342	REAL(rstd),POINTER :: u(:,:)
343	REAL(rstd),POINTER :: wflux(:,:)
344	REAL(rstd),POINTER :: q(:,:,:)
345	REAL(rstd),POINTER :: p(:,:)
346	REAL(rstd),POINTER :: pks(:)
347	REAL(rstd),POINTER :: pk(:,:)
348	REAL(rstd),POINTER :: p_layer(:,:)
349	REAL(rstd),POINTER :: theta(:,:)
350	REAL(rstd),POINTER :: phi(:,:)
351	REAL(rstd),POINTER :: Temp(:,:)
352	REAL(rstd),POINTER :: ulon(:,:)
353	REAL(rstd),POINTER :: ulat(:,:)
354	REAL(rstd),POINTER :: dulon(:,:)
355	REAL(rstd),POINTER :: dulat(:,:)
356	REAL(rstd),POINTER :: dTemp(:,:)
357	REAL(rstd),POINTER :: dq(:,:,:)
358	REAL(rstd),POINTER :: dps(:)
359	REAL(rstd),POINTER :: duc(:,:,:)
360
361
362	INTEGER :: ind
363
364	REAL(rstd),ALLOCATABLE,SAVE :: ps_phy(:)
365	!$OMP THREADPRIVATE(ps_phy)
366	REAL(rstd),ALLOCATABLE,SAVE :: p_phy(:,:)
367	!$OMP THREADPRIVATE(p_phy)
368	REAL(rstd),ALLOCATABLE,SAVE :: p_layer_phy(:,:)
369	!$OMP THREADPRIVATE(p_layer_phy)
370	REAL(rstd),ALLOCATABLE,SAVE :: Temp_phy(:,:)
371	!$OMP THREADPRIVATE(Temp_phy)
372	REAL(rstd),ALLOCATABLE,SAVE :: phis_phy(:)
373	!$OMP THREADPRIVATE(phis_phy)
374	REAL(rstd),ALLOCATABLE,SAVE :: phi_phy(:,:)
375	!$OMP THREADPRIVATE(phi_phy)
376	REAL(rstd),ALLOCATABLE,SAVE :: ulon_phy(:,:)
377	!$OMP THREADPRIVATE(ulon_phy)
378	REAL(rstd),ALLOCATABLE,SAVE :: ulat_phy(:,:)
379	!$OMP THREADPRIVATE(ulat_phy)
380	REAL(rstd),ALLOCATABLE,SAVE :: q_phy(:,:,:)
381	!$OMP THREADPRIVATE(q_phy)
382	REAL(rstd),ALLOCATABLE,SAVE :: wflux_phy(:,:)
383	!$OMP THREADPRIVATE(wflux_phy)
384	REAL(rstd),ALLOCATABLE,SAVE :: dulon_phy(:,:)
385	!$OMP THREADPRIVATE(dulon_phy)
386	REAL(rstd),ALLOCATABLE,SAVE :: dulat_phy(:,:)
387	!$OMP THREADPRIVATE(dulat_phy)
388	REAL(rstd),ALLOCATABLE,SAVE :: dTemp_phy(:,:)
389	!$OMP THREADPRIVATE(dTemp_phy)
390	REAL(rstd),ALLOCATABLE,SAVE :: dq_phy(:,:,:)
391	!$OMP THREADPRIVATE(dq_phy)
392	REAL(rstd),ALLOCATABLE,SAVE :: dps_phy(:)
393	!$OMP THREADPRIVATE(dps_phy)
394	REAL(rstd) :: dtphy
395	LOGICAL :: debut
396	LOGICAL :: lafin
397	LOGICAL,SAVE :: first=.TRUE.
398	!$OMP THREADPRIVATE(first)
399
400
401	IF(first) THEN
402	debut=.TRUE.
403	ELSE
404	debut=.FALSE.
405	ENDIF
406
407
408	IF(it-itau0>=itaumax) THEN
409	lafin=.TRUE.
410	ELSE
411	lafin=.FALSE.
412	ENDIF
413
414	IF (first) THEN
415	first=.FALSE.
416	CALL init_message(f_u,req_e1_vect,req_u)
417	ALLOCATE(ps_phy(klon_omp))
418	ALLOCATE(p_phy(klon_omp,llm+1))
419	ALLOCATE(p_layer_phy(klon_omp,llm))
420	ALLOCATE(Temp_phy(klon_omp,llm))
421	ALLOCATE(phis_phy(klon_omp))
422	ALLOCATE(phi_phy(klon_omp,llm))
423	ALLOCATE(ulon_phy(klon_omp,llm))
424	ALLOCATE(ulat_phy(klon_omp,llm))
425	ALLOCATE(q_phy(klon_omp,llm,nqtot))
426	ALLOCATE(wflux_phy(klon_omp,llm))
427	ALLOCATE(dulon_phy(klon_omp,llm))
428	ALLOCATE(dulat_phy(klon_omp,llm))
429	ALLOCATE(dTemp_phy(klon_omp,llm))
430	ALLOCATE(dq_phy(klon_omp,llm,nqtot))
431	ALLOCATE(dps_phy(klon_omp))
432	!$OMP BARRIER
433	ENDIF
434
435
436	!$OMP MASTER
437	! CALL update_calendar(it)
438	!$OMP END MASTER
439	!$OMP BARRIER
440	dtphy=itau_physics*dt
441
442
443
444	CALL transfert_message(f_u,req_u)
445
446	DO ind=1,ndomain
447	CALL swap_dimensions(ind)
448	IF (assigned_domain(ind)) THEN
449	CALL swap_geometry(ind)
450
451	phis=f_phis(ind)
452	ps=f_ps(ind)
453	theta_rhodz=f_theta_rhodz(ind)
454	u=f_u(ind)
455	q=f_q(ind)
456	wflux=f_wflux(ind)
457	p=f_p(ind)
458	pks=f_pks(ind)
459	pk=f_pk(ind)
460	p_layer=f_p_layer(ind)
461	theta=f_theta(ind)
462	phi=f_phi(ind)
463	Temp=f_Temp(ind)
464	ulon=f_ulon(ind)
465	ulat=f_ulat(ind)
466
467	CALL grid_icosa_to_physics
468
469	ENDIF
470	ENDDO
471
472	!$OMP BARRIER
473	!$OMP MASTER
474	CALL SYSTEM_CLOCK(start_clock)
475	!$OMP END MASTER
476	CALL trace_start("physic")
477	! CALL trace_off()
478
479
480
481	CALL transfer_icosa_to_lmdz(f_p , p_phy)
482	CALL transfer_icosa_to_lmdz(f_p_layer, p_layer_phy)
483	CALL transfer_icosa_to_lmdz(f_phi , phi_phy)
484	CALL transfer_icosa_to_lmdz(f_phis , phis_phy )
485	CALL transfer_icosa_to_lmdz(f_ulon , ulon_phy )
486	CALL transfer_icosa_to_lmdz(f_ulat , ulat_phy)
487	CALL transfer_icosa_to_lmdz(f_Temp , Temp_phy)
488	CALL transfer_icosa_to_lmdz(f_q , q_phy)
489	CALL transfer_icosa_to_lmdz(f_wflux , wflux_phy)
490
491	CALL wxios_set_context()
492
493	CALL physiq(klon_omp, llm, debut, lafin, dtphy, &
494	p_phy, p_layer_phy, phi_phy, phis_phy, presnivs, ulon_phy, ulat_phy, Temp_phy, q_phy, wflux_phy, &
495	dulon_phy, dulat_phy, dTemp_phy, dq_phy, dps_phy)
496
497	CALL transfer_lmdz_to_icosa(dulon_phy, f_dulon )
498	CALL transfer_lmdz_to_icosa(dulat_phy, f_dulat )
499	CALL transfer_lmdz_to_icosa(dTemp_phy, f_dTemp )
500	CALL transfer_lmdz_to_icosa(dq_phy , f_dq )
501	CALL transfer_lmdz_to_icosa(dps_phy , f_dps )
502
503	CALL send_message(f_dps,req_dps0)
504	CALL send_message(f_dulon,req_dulon0)
505	CALL send_message(f_dulat,req_dulat0)
506	CALL send_message(f_dTemp,req_dTemp0)
507	CALL send_message(f_dq,req_dq0)
508
509	CALL wait_message(req_dps0)
510	CALL wait_message(req_dulon0)
511	CALL wait_message(req_dulat0)
512	CALL wait_message(req_dTemp0)
513	CALL wait_message(req_dq0)
514
515
516	! CALL trace_on()
517	CALL trace_end("physic")
518	!$OMP MASTER
519	CALL SYSTEM_CLOCK(stop_clock)
520	count_clock=count_clock+stop_clock-start_clock
521	!$OMP END MASTER
522
523	!$OMP BARRIER
524
525	DO ind=1,ndomain
526	CALL swap_dimensions(ind)
527	IF (assigned_domain(ind)) THEN
528	CALL swap_geometry(ind)
529
530	theta_rhodz=f_theta_rhodz(ind)
531	u=f_u(ind)
532	q=f_q(ind)
533	ps=f_ps(ind)
534	dulon=f_dulon(ind)
535	dulat=f_dulat(ind)
536	Temp=f_temp(ind)
537	dTemp=f_dTemp(ind)
538	dq=f_dq(ind)
539	dps=f_dps(ind)
540	duc=f_duc(ind)
541	p=f_p(ind)
542	pks=f_pks(ind)
543	pk=f_pk(ind)
544
545	CALL grid_physics_to_icosa
546	ENDIF
547	ENDDO
548
549	!$OMP BARRIER
550	CALL xios_set_context
551
552
553	CONTAINS
554
555	SUBROUTINE grid_icosa_to_physics
556	USE pression_mod
557	USE exner_mod
558	USE theta2theta_rhodz_mod
559	USE geopotential_mod
560	USE wind_mod
561	USE omp_para
562	IMPLICIT NONE
563
564	REAL(rstd) :: uc(3)
565	INTEGER :: i,j,ij,l
566
567
568	! compute pression
569
570	DO l = ll_begin,ll_endp1
571	DO j=jj_begin,jj_end
572	DO i=ii_begin,ii_end
573	ij=(j-1)*iim+i
574	p(ij,l) = ap(l) + bp(l) * ps(ij)
575	ENDDO
576	ENDDO
577	ENDDO
578
579	!$OMP BARRIER
580
581	! compute exner
582
583	IF (is_omp_first_level) THEN
584	DO j=jj_begin,jj_end
585	DO i=ii_begin,ii_end
586	ij=(j-1)*iim+i
587	pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
588	ENDDO
589	ENDDO
590	ENDIF
591
592	! 3D : pk
593	DO l = ll_begin,ll_end
594	DO j=jj_begin,jj_end
595	DO i=ii_begin,ii_end
596	ij=(j-1)*iim+i
597	pk(ij,l) = cpp * ((.5/preff)(p(ij,l)+p(ij,l+1))) * kappa
598	ENDDO
599	ENDDO
600	ENDDO
601
602	!$OMP BARRIER
603
604	! compute theta, temperature and pression at layer
605	DO l = ll_begin, ll_end
606	DO j=jj_begin,jj_end
607	DO i=ii_begin,ii_end
608	ij=(j-1)*iim+i
609	theta(ij,l) = theta_rhodz(ij,l) / ((p(ij,l)-p(ij,l+1))/g)
610	Temp(ij,l) = theta(ij,l) * pk(ij,l) / cpp
611	p_layer(ij,l)=preff(pk(ij,l)/cpp)*(1./kappa)
612	ENDDO
613	ENDDO
614	ENDDO
615
616
617	!!! Compute geopotential
618
619	! for first layer
620	IF (is_omp_first_level) THEN
621	DO j=jj_begin,jj_end
622	DO i=ii_begin,ii_end
623	ij=(j-1)*iim+i
624	phi( ij,1 ) = phis( ij ) + theta(ij,1) * ( pks(ij) - pk(ij,1) )
625	ENDDO
626	ENDDO
627	ENDIF
628	!!-> implicit flush on phi(:,1)
629
630	! for other layers
631	DO l = ll_beginp1, ll_end
632	DO j=jj_begin,jj_end
633	DO i=ii_begin,ii_end
634	ij=(j-1)*iim+i
635	phi(ij,l) = 0.5 * ( theta(ij,l) + theta(ij,l-1) ) &
636	* ( pk(ij,l-1) - pk(ij,l) )
637	ENDDO
638	ENDDO
639	ENDDO
640
641	!$OMP BARRIER
642
643
644	IF (is_omp_first_level) THEN
645	DO l = 2, llm
646	DO j=jj_begin,jj_end
647	! ---> Bug compilo intel ici en openmp
648	! ---> Couper la boucle
649	IF (j==jj_end+1) PRINT*,"this message must not be printed"
650	DO i=ii_begin,ii_end
651	ij=(j-1)*iim+i
652	phi(ij,l) = phi(ij,l)+ phi(ij,l-1)
653	ENDDO
654	ENDDO
655	ENDDO
656	! --> IMPLICIT FLUSH on phi --> non
657	ENDIF
658
659	! compute wind centered lon lat compound
660	DO l=ll_begin,ll_end
661	DO j=jj_begin,jj_end
662	DO i=ii_begin,ii_end
663	ij=(j-1)*iim+i
664	uc(:)=1/Ai(ij)* &
665	( 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,:)) &
666	+ 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,:)) &
667	+ 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,:)) &
668	+ 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,:)) &
669	+ 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,:))&
670	+ 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,:)))
671	ulon(ij,l)=sum(uc(:)*elon_i(ij,:))
672	ulat(ij,l)=sum(uc(:)*elat_i(ij,:))
673	ENDDO
674	ENDDO
675	ENDDO
676
677	!$OMP BARRIER
678	END SUBROUTINE grid_icosa_to_physics
679
680
681	SUBROUTINE grid_physics_to_icosa
682	USE theta2theta_rhodz_mod
683	USE omp_para
684	IMPLICIT NONE
685	INTEGER :: i,j,ij,l,iq
686
687	DO l=ll_begin,ll_end
688	DO j=jj_begin,jj_end
689	DO i=ii_begin,ii_end
690	ij=(j-1)*iim+i
691	duc(ij,:,l)=dulon(ij,l)elon_i(ij,:)+dulat(ij,l)elat_i(ij,:)
692	ENDDO
693	ENDDO
694	ENDDO
695
696	DO l=ll_begin,ll_end
697	DO j=jj_begin,jj_end
698	DO i=ii_begin,ii_end
699	ij=(j-1)*iim+i
700	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,:) )
701	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,:) )
702	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,:) )
703	ENDDO
704	ENDDO
705	ENDDO
706
707	DO l=ll_begin,ll_end
708	DO j=jj_begin,jj_end
709	DO i=ii_begin,ii_end
710	ij=(j-1)*iim+i
711	Temp(ij,l)=Temp(ij,l)+ dtphy * dTemp(ij,l)
712	ENDDO
713	ENDDO
714	ENDDO
715
716	DO iq=1,nqtot
717	DO l=ll_begin,ll_end
718	DO j=jj_begin,jj_end
719	DO i=ii_begin,ii_end
720	ij=(j-1)*iim+i
721	q(ij,l,iq)=q(ij,l,iq)+ dtphy * dq(ij,l,iq)
722	ENDDO
723	ENDDO
724	ENDDO
725	ENDDO
726
727	!$OMP BARRIER
728
729	IF (is_omp_first_level) THEN
730	DO j=jj_begin,jj_end
731	DO i=ii_begin,ii_end
732	ij=(j-1)*iim+i
733	ps(ij)=ps(ij)+ dtphy * dps(ij)
734	ENDDO
735	ENDDO
736	ENDIF
737
738	! CALL compute_temperature2theta_rhodz(ps,Temp,theta_rhodz,0)
739
740	! compute pression
741	!$OMP BARRIER
742	DO l = ll_begin,ll_endp1
743	DO j=jj_begin,jj_end
744	DO i=ii_begin,ii_end
745	ij=(j-1)*iim+i
746	p(ij,l) = ap(l) + bp(l) * ps(ij)
747	ENDDO
748	ENDDO
749	ENDDO
750
751	!$OMP BARRIER
752
753	! compute exner
754
755	IF (is_omp_first_level) THEN
756	DO j=jj_begin,jj_end
757	DO i=ii_begin,ii_end
758	ij=(j-1)*iim+i
759	pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
760	ENDDO
761	ENDDO
762	ENDIF
763
764	! 3D : pk
765	DO l = ll_begin,ll_end
766	DO j=jj_begin,jj_end
767	DO i=ii_begin,ii_end
768	ij=(j-1)*iim+i
769	pk(ij,l) = cpp * ((.5/preff)(p(ij,l)+p(ij,l+1))) * kappa
770	ENDDO
771	ENDDO
772	ENDDO
773
774	!$OMP BARRIER
775
776	! compute theta, temperature and pression at layer
777	DO l = ll_begin, ll_end
778	DO j=jj_begin,jj_end
779	DO i=ii_begin,ii_end
780	ij=(j-1)*iim+i
781	theta_rhodz(ij,l) = temp(ij,l) * ((p(ij,l)-p(ij,l+1))/g) / (pk(ij,l) / cpp )
782	ENDDO
783	ENDDO
784	ENDDO
785
786	END SUBROUTINE grid_physics_to_icosa
787
788
789
790	END SUBROUTINE physics
791
792
793
794
795
796	END MODULE interface_icosa_lmdz_mod

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

Download in other formats:

Original Format