MODULE physics_lmdz_generic_mod USE field_mod USE transfert_mod INTEGER,SAVE :: nbp_phys TYPE(t_message) :: req_u TYPE(t_field),POINTER :: f_p(:) TYPE(t_field),POINTER :: f_pks(:) TYPE(t_field),POINTER :: f_pk(:) TYPE(t_field),POINTER :: f_p_layer(:) TYPE(t_field),POINTER :: f_theta(:) TYPE(t_field),POINTER :: f_phi(:) TYPE(t_field),POINTER :: f_Temp(:) TYPE(t_field),POINTER :: f_ulon(:) TYPE(t_field),POINTER :: f_ulat(:) TYPE(t_field),POINTER :: f_dulon(:) TYPE(t_field),POINTER :: f_dulat(:) TYPE(t_field),POINTER :: f_dTemp(:) TYPE(t_field),POINTER :: f_dq(:) TYPE(t_field),POINTER :: f_dps(:) TYPE(t_field),POINTER :: f_duc(:) INTEGER :: start_clock INTEGER :: stop_clock INTEGER :: count_clock=0 REAL :: start_day REAL :: day_length REAL :: year_length INTEGER,ALLOCATABLE,SAVE :: domain_offset(:) CONTAINS SUBROUTINE init_physics USE icosa USE domain_mod USE dimensions USE mpi_mod USE mpipara USE disvert_mod USE xios_mod IMPLICIT NONE INTEGER :: distrib(0:mpi_size-1) INTEGER :: ind,i,j,ij,pos REAL(rstd),ALLOCATABLE :: latfi(:) REAL(rstd),ALLOCATABLE :: lonfi(:) REAL(rstd),ALLOCATABLE :: airefi(:) REAL(rstd),ALLOCATABLE :: bounds_latfi(:,:) REAL(rstd),ALLOCATABLE :: bounds_lonfi(:,:) INTEGER :: time0 start_day=0 day_length=86400 year_length=86400*365.25 CALL getin('start_day',start_day) CALL getin('day_length',day_length) CALL getin('year_length',year_length) !$OMP PARALLEL CALL allocate_field(f_p,field_t,type_real,llm+1) CALL allocate_field(f_pks,field_t,type_real) CALL allocate_field(f_pk,field_t,type_real,llm) CALL allocate_field(f_p_layer,field_t,type_real,llm) CALL allocate_field(f_theta,field_t,type_real,llm) CALL allocate_field(f_phi,field_t,type_real,llm) CALL allocate_field(f_Temp,field_t,type_real,llm) CALL allocate_field(f_ulon,field_t,type_real,llm) CALL allocate_field(f_ulat,field_t,type_real,llm) CALL allocate_field(f_dulon,field_t,type_real,llm) CALL allocate_field(f_dulat,field_t,type_real,llm) CALL allocate_field(f_dTemp,field_t,type_real,llm) CALL allocate_field(f_dq,field_t,type_real,llm,nqtot) CALL allocate_field(f_dps,field_t,type_real) CALL allocate_field(f_duc,field_t,type_real,3,llm) !$OMP END PARALLEL ALLOCATE(domain_offset(ndomain)) nbp_phys=0 domain_offset(1)=0 DO ind=1,ndomain CALL swap_dimensions(ind) IF (ind itau0+itaumax) THEN lafin=.TRUE. ELSE lafin=.FALSE. ENDIF !$OMP MASTER ! CALL update_calendar(it) !$OMP END MASTER !$OMP BARRIER dtphy=itau_physics*dt real_time=start_day*day_length+it*dt day = INT( MODULO(real_time,year_length) / day_length) time = MODULO(real_time,day_length) / day_length !$OMP MASTER IF (is_mpi_root) PRINT*,"Enterring in physic : day", day, " time : ",time !$OMP END MASTER CALL transfert_message(f_u,req_u) DO ind=1,ndomain CALL swap_dimensions(ind) IF (assigned_domain(ind)) THEN offset=domain_offset(ind) CALL swap_geometry(ind) phis=f_phis(ind) ps=f_ps(ind) theta_rhodz=f_theta_rhodz(ind) u=f_u(ind) q=f_q(ind) wflux=f_wflux(ind) p=f_p(ind) pks=f_pks(ind) pk=f_pk(ind) p_layer=f_p_layer(ind) theta=f_theta(ind) phi=f_phi(ind) Temp=f_Temp(ind) ulon=f_ulon(ind) ulat=f_ulat(ind) CALL grid_icosa_to_physics ENDIF ENDDO !$OMP BARRIER !$OMP MASTER CALL SYSTEM_CLOCK(start_clock) !$OMP END MASTER CALL calfis_icosa(dtphy, lafin, day, time, presnivs, & p_phy, p_layer_phy, phi_phy, phis_phy, ulon_phy, ulat_phy, Temp_phy, q_phy, wflux_phy, & dulon_phy, dulat_phy, dTemp_phy, dq_phy, dps_phy ) !$OMP MASTER CALL SYSTEM_CLOCK(stop_clock) count_clock=count_clock+stop_clock-start_clock !$OMP END MASTER !$OMP BARRIER DO ind=1,ndomain CALL swap_dimensions(ind) IF (assigned_domain(ind)) THEN CALL swap_geometry(ind) offset=domain_offset(ind) theta_rhodz=f_theta_rhodz(ind) u=f_u(ind) q=f_q(ind) ps=f_ps(ind) dulon=f_dulon(ind) dulat=f_dulat(ind) Temp=f_temp(ind) dTemp=f_dTemp(ind) dq=f_dq(ind) dps=f_dps(ind) duc=f_duc(ind) p=f_p(ind) pks=f_pks(ind) pk=f_pk(ind) CALL grid_physics_to_icosa ENDIF ENDDO !$OMP BARRIER CALL xios_set_context CONTAINS SUBROUTINE grid_physics_to_icosa USE theta2theta_rhodz_mod USE omp_para IMPLICIT NONE INTEGER :: i,j,ij,l,iq DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i offset=offset+1 dulon(ij,ll_begin:ll_end)=dulon_phy(offset,ll_begin:ll_end) dulat(ij,ll_begin:ll_end)=dulat_phy(offset,ll_begin:ll_end) dTemp(ij,ll_begin:ll_end)=dTemp_phy(offset,ll_begin:ll_end) Temp(ij,ll_begin:ll_end) = Temp_phy(offset,ll_begin:ll_end) dq(ij,ll_begin:ll_end,:)=dq_phy(offset,ll_begin:ll_end,:) if (omp_first) dps(ij)=dps_phy(offset) ENDDO ENDDO DO l=ll_begin,ll_end DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i duc(ij,:,l)=dulon(ij,l)*elon_i(ij,:)+dulat(ij,l)*elat_i(ij,:) ENDDO ENDDO ENDDO DO l=ll_begin,ll_end DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i 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,:) ) 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,:) ) u(ij+u_ldown,l) = u(ij+u_ldown,l) + dtphy*sum( 0.5*(duc(ij,:,l) + duc(ij+t_ldown,:,l))*ep_e(ij+u_ldown,:) ) ENDDO ENDDO ENDDO DO l=ll_begin,ll_end DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i Temp(ij,l)=Temp(ij,l)+ dtphy * dTemp(ij,l) ENDDO ENDDO ENDDO DO iq=1,nqtot DO l=ll_begin,ll_end DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i q(ij,l,iq)=q(ij,l,iq)+ dtphy * dq(ij,l,iq) ENDDO ENDDO ENDDO ENDDO !$OMP BARRIER IF (omp_first) THEN DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i ps(ij)=ps(ij)+ dtphy * dps(ij) ENDDO ENDDO ENDIF ! CALL compute_temperature2theta_rhodz(ps,Temp,theta_rhodz,0) ! compute pression !$OMP BARRIER DO l = ll_begin,ll_endp1 DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i p(ij,l) = ap(l) + bp(l) * ps(ij) ENDDO ENDDO ENDDO !$OMP BARRIER ! compute exner IF (omp_first) THEN DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i pks(ij) = cpp * ( ps(ij)/preff ) ** kappa ENDDO ENDDO ENDIF ! 3D : pk DO l = ll_begin,ll_end DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i pk(ij,l) = cpp * ((.5/preff)*(p(ij,l)+p(ij,l+1))) ** kappa ENDDO ENDDO ENDDO !$OMP BARRIER ! compute theta, temperature and pression at layer DO l = ll_begin, ll_end DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i theta_rhodz(ij,l) = temp(ij,l) * ((p(ij,l)-p(ij,l+1))/g) / (pk(ij,l) / cpp ) ENDDO ENDDO ENDDO END SUBROUTINE grid_physics_to_icosa SUBROUTINE grid_icosa_to_physics USE pression_mod USE exner_mod USE theta2theta_rhodz_mod USE geopotential_mod USE wind_mod USE omp_para IMPLICIT NONE REAL(rstd) :: uc(3) INTEGER :: i,j,ij,l ! compute pression DO l = ll_begin,ll_endp1 DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i p(ij,l) = ap(l) + bp(l) * ps(ij) ENDDO ENDDO ENDDO !$OMP BARRIER ! compute exner IF (omp_first) THEN DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i pks(ij) = cpp * ( ps(ij)/preff ) ** kappa ENDDO ENDDO ENDIF ! 3D : pk DO l = ll_begin,ll_end DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i pk(ij,l) = cpp * ((.5/preff)*(p(ij,l)+p(ij,l+1))) ** kappa ENDDO ENDDO ENDDO !$OMP BARRIER ! compute theta, temperature and pression at layer DO l = ll_begin, ll_end DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i theta(ij,l) = theta_rhodz(ij,l) / ((p(ij,l)-p(ij,l+1))/g) Temp(ij,l) = theta(ij,l) * pk(ij,l) / cpp p_layer(ij,l)=preff*(pk(ij,l)/cpp)**(1./kappa) ENDDO ENDDO ENDDO !!! Compute geopotential ! for first layer IF (omp_first) THEN DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i phi( ij,1 ) = phis( ij ) + theta(ij,1) * ( pks(ij) - pk(ij,1) ) ENDDO ENDDO ENDIF !!-> implicit flush on phi(:,1) ! for other layers DO l = ll_beginp1, ll_end DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i phi(ij,l) = 0.5 * ( theta(ij,l) + theta(ij,l-1) ) & * ( pk(ij,l-1) - pk(ij,l) ) ENDDO ENDDO ENDDO !$OMP BARRIER DO l = 2, llm DO j=jj_begin,jj_end ! ---> Bug compilo intel ici en openmp ! ---> Couper la boucle if (j==jj_end+1) PRINT*,"this message must not be printed" DO i=ii_begin,ii_end ij=(j-1)*iim+i phi(ij,l) = phi(ij,l)+ phi(ij,l-1) ENDDO ENDDO ENDDO ! --> IMPLICIT FLUSH on phi ! compute wind centered lon lat compound DO l=ll_begin,ll_end DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i uc(:)=1/Ai(ij)* & ( 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,:)) & + 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,:)) & + 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,:)) & + 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,:)) & + 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,:))& + 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,:))) ulon(ij,l)=sum(uc(:)*elon_i(ij,:)) ulat(ij,l)=sum(uc(:)*elat_i(ij,:)) ENDDO ENDDO ENDDO !$OMP BARRIER DO j=jj_begin,jj_end DO i=ii_begin,ii_end ij=(j-1)*iim+i offset=offset+1 IF (omp_first) ps_phy(offset) = ps(ij) p_phy(offset,ll_begin:ll_endp1) = p(ij,ll_begin:ll_endp1) p_layer_phy(offset,ll_begin:ll_end) = p_layer(ij,ll_begin:ll_end) Temp_phy(offset,ll_begin:ll_end) = Temp(ij,ll_begin:ll_end) IF (omp_first) phis_phy(offset) = phis(ij) phi_phy(offset,ll_begin:ll_end) = phi(ij,ll_begin:ll_end)-phis(ij) ulon_phy(offset,ll_begin:ll_end) = ulon(ij,ll_begin:ll_end) ulat_phy(offset,ll_begin:ll_end) = ulat(ij,ll_begin:ll_end) q_phy(offset,ll_begin:ll_end,:) = q(ij,ll_begin:ll_end,:) wflux_phy(offset,ll_begin:ll_end) = wflux(ij,ll_begin:ll_end) ENDDO ENDDO END SUBROUTINE grid_icosa_to_physics END SUBROUTINE physics END MODULE physics_lmdz_generic_mod