Context Navigation

interface_icosa_lmdz.f90 @ 4498

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

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

Download in other formats:

Original Format