source: codes/icosagcm/trunk/src/etat0.f90 @ 342

Last change on this file since 342 was 327, checked in by ymipsl, 9 years ago

Merge recent developments from saturn branch onto trunk.

  • lmdz generic physics interface
  • performance improvment on mix mpi/openmp
  • asynchrone and overlaping communication
  • best domain distribution between process and threads
  • ....

This version is compatible with the actual saturn version and the both branches are considered merged on dynamico component.

YM
File size: 8.5 KB
Line 
1MODULE etat0_mod
2  USE icosa
3  PRIVATE
4
5    CHARACTER(len=255),SAVE :: etat0_type
6!$OMP THREADPRIVATE(etat0_type)
7
8    REAL(rstd) :: etat0_temp
9
10    PUBLIC :: etat0, etat0_type
11
12CONTAINS
13 
14  SUBROUTINE etat0(f_ps,f_mass,f_phis,f_theta_rhodz,f_u, f_q)
15    USE mpipara, ONLY : is_mpi_root
16    USE disvert_mod
17    ! New interface
18    USE etat0_dcmip5_mod, ONLY : getin_etat0_dcmip5=>getin_etat0
19    USE etat0_williamson_mod, ONLY : getin_etat0_williamson=>getin_etat0
20    USE etat0_temperature_mod, ONLY: getin_etat0_temperature=>getin_etat0
21    ! Old interface
22    USE etat0_academic_mod, ONLY : etat0_academic=>etat0 
23    USE etat0_dcmip1_mod, ONLY : etat0_dcmip1=>etat0
24    USE etat0_dcmip2_mod, ONLY : etat0_dcmip2=>etat0
25    USE etat0_dcmip3_mod, ONLY : etat0_dcmip3=>etat0 
26    USE etat0_dcmip4_mod, ONLY : etat0_dcmip4=>etat0 
27    USE etat0_heldsz_mod, ONLY : etat0_heldsz=>etat0 
28    USE etat0_venus_mod,  ONLY : etat0_venus=>etat0 
29    USE etat0_start_file_mod, ONLY : etat0_start_file=>etat0 
30
31    IMPLICIT NONE
32    TYPE(t_field),POINTER :: f_ps(:)
33    TYPE(t_field),POINTER :: f_mass(:)
34    TYPE(t_field),POINTER :: f_phis(:)
35    TYPE(t_field),POINTER :: f_theta_rhodz(:)
36    TYPE(t_field),POINTER :: f_u(:)
37    TYPE(t_field),POINTER :: f_q(:)
38   
39    REAL(rstd),POINTER :: ps(:), mass(:,:)
40    LOGICAL :: init_mass
41    INTEGER :: ind,i,j,ij,l
42
43    ! most etat0 routines set ps and not mass
44    ! in that case and if caldyn_eta == eta_lag
45    ! the initial distribution of mass is taken to be the same
46    ! as what the mass coordinate would dictate
47    ! however if etat0_XXX defines mass then the flag init_mass must be set to .FALSE.
48    ! otherwise mass will be overwritten
49    init_mass = (caldyn_eta == eta_lag)
50
51    etat0_type='jablonowsky06'
52    CALL getin("etat0",etat0_type)
53   
54    SELECT CASE (TRIM(etat0_type))
55       !------------------- New interface ---------------------
56    CASE ('isothermal')
57       CALL getin_etat0_isothermal
58       CALL etat0_collocated(f_phis,f_ps,f_mass,f_theta_rhodz,f_u, f_q)
59    CASE ('temperature_profile')
60       CALL getin_etat0_temperature
61       CALL etat0_collocated(f_phis,f_ps,f_mass,f_theta_rhodz,f_u, f_q)
62    CASE ('jablonowsky06')
63       CALL etat0_collocated(f_phis,f_ps,f_mass,f_theta_rhodz,f_u, f_q)
64     CASE ('dcmip5')
65        CALL getin_etat0_dcmip5
66        CALL etat0_collocated(f_phis,f_ps,f_mass,f_theta_rhodz,f_u, f_q)
67    CASE ('williamson91.6')
68       init_mass=.FALSE.
69       CALL getin_etat0_williamson
70       CALL etat0_collocated(f_phis,f_ps,f_mass,f_theta_rhodz,f_u, f_q)
71       !------------------- Old interface --------------------
72    CASE ('start_file')
73       CALL etat0_start_file(f_ps,f_phis,f_theta_rhodz,f_u, f_q)
74    CASE ('academic')
75       CALL etat0_academic(f_ps,f_phis,f_theta_rhodz,f_u, f_q)
76    CASE ('held_suarez')
77       PRINT *,"Held & Suarez (1994) test case"
78       CALL etat0_heldsz(f_ps,f_phis,f_theta_rhodz,f_u, f_q)
79    CASE ('venus')
80       CALL etat0_venus(f_ps, f_phis, f_theta_rhodz, f_u, f_q)
81       PRINT *, "Venus (Lebonnois et al., 2012) test case"
82    CASE ('dcmip1')
83       CALL etat0_dcmip1(f_ps,f_phis,f_theta_rhodz,f_u, f_q)
84    CASE ('dcmip2_mountain','dcmip2_schaer_noshear','dcmip2_schaer_shear')
85       CALL etat0_dcmip2(f_ps,f_phis,f_theta_rhodz,f_u, f_q)
86    CASE ('dcmip3')
87       CALL etat0_dcmip3(f_ps,f_phis,f_theta_rhodz,f_u, f_q)
88    CASE ('dcmip4')
89        IF(nqtot<2) THEN
90           IF (is_mpi_root)  THEN
91              PRINT *, "nqtot must be at least 2 for test case DCMIP4"
92           END IF
93           STOP
94        END IF
95        CALL etat0_dcmip4(f_ps,f_phis,f_theta_rhodz,f_u, f_q)
96   CASE DEFAULT
97       PRINT*, 'Bad selector for variable etat0 <',etat0_type, &
98            '> options are <jablonowsky06>, <academic>, <dcmip[1-4]> '
99       STOP
100    END SELECT
101
102    IF(init_mass) THEN ! initialize mass distribution using ps
103!       !$OMP BARRIER
104       DO ind=1,ndomain
105          IF (.NOT. assigned_domain(ind)) CYCLE
106          CALL swap_dimensions(ind)
107          CALL swap_geometry(ind)
108          mass=f_mass(ind); ps=f_ps(ind)
109          CALL compute_rhodz(.TRUE., ps, mass)
110       END DO
111    END IF
112
113  END SUBROUTINE etat0
114
115  SUBROUTINE etat0_collocated(f_phis,f_ps,f_mass,f_theta_rhodz,f_u, f_q)
116    USE theta2theta_rhodz_mod
117    IMPLICIT NONE
118    TYPE(t_field),POINTER :: f_ps(:)
119    TYPE(t_field),POINTER :: f_mass(:)
120    TYPE(t_field),POINTER :: f_phis(:)
121    TYPE(t_field),POINTER :: f_theta_rhodz(:)
122    TYPE(t_field),POINTER :: f_u(:)
123    TYPE(t_field),POINTER :: f_q(:)
124 
125    TYPE(t_field),POINTER,SAVE :: f_temp(:)
126    REAL(rstd),POINTER :: ps(:)
127    REAL(rstd),POINTER :: mass(:,:)
128    REAL(rstd),POINTER :: phis(:)
129    REAL(rstd),POINTER :: theta_rhodz(:,:)
130    REAL(rstd),POINTER :: temp(:,:)
131    REAL(rstd),POINTER :: u(:,:)
132    REAL(rstd),POINTER :: q(:,:,:)
133    INTEGER :: ind
134
135    CALL allocate_field(f_temp,field_t,type_real,llm,name='temp')
136
137    DO ind=1,ndomain
138      IF (.NOT. assigned_domain(ind)) CYCLE
139      CALL swap_dimensions(ind)
140      CALL swap_geometry(ind)
141      ps=f_ps(ind)
142      mass=f_mass(ind)
143      phis=f_phis(ind)
144      theta_rhodz=f_theta_rhodz(ind)
145      temp=f_temp(ind)
146      u=f_u(ind)
147      q=f_q(ind)
148
149      IF( TRIM(etat0_type)=='williamson91.6' ) THEN
150       CALL compute_etat0_collocated(ps,mass, phis, theta_rhodz, u, q)
151      ELSE
152       CALL compute_etat0_collocated(ps,mass, phis, temp, u, q)
153      ENDIF
154    ENDDO
155   
156    IF( TRIM(etat0_type)/='williamson91.6' ) CALL temperature2theta_rhodz(f_ps,f_temp,f_theta_rhodz)
157   
158    CALL deallocate_field(f_temp)
159   
160  END SUBROUTINE etat0_collocated
161
162  SUBROUTINE compute_etat0_collocated(ps,mass, phis, temp_i, u, q)
163    USE wind_mod
164    USE etat0_jablonowsky06_mod, ONLY : compute_jablonowsky06 => compute_etat0
165    USE etat0_dcmip5_mod, ONLY : compute_dcmip5 => compute_etat0
166    USE etat0_williamson_mod, ONLY : compute_w91_6 => compute_etat0
167    USE etat0_temperature_mod, ONLY: compute_etat0_temperature => compute_etat0
168    IMPLICIT NONE
169    REAL(rstd),INTENT(INOUT) :: ps(iim*jjm)
170    REAL(rstd),INTENT(INOUT) :: mass(iim*jjm,llm)
171    REAL(rstd),INTENT(OUT) :: phis(iim*jjm)
172    REAL(rstd),INTENT(OUT) :: temp_i(iim*jjm,llm)
173    REAL(rstd),INTENT(OUT) :: u(3*iim*jjm,llm)
174    REAL(rstd),INTENT(OUT) :: q(iim*jjm,llm,nqtot)
175
176    REAL(rstd) :: ulon_i(iim*jjm,llm)
177    REAL(rstd) :: ulat_i(iim*jjm,llm)
178
179    REAL(rstd) :: ps_e(3*iim*jjm)
180    REAL(rstd) :: mass_e(3*iim*jjm,llm)
181    REAL(rstd) :: phis_e(3*iim*jjm)
182    REAL(rstd) :: temp_e(3*iim*jjm,llm)
183    REAL(rstd) :: ulon_e(3*iim*jjm,llm)
184    REAL(rstd) :: ulat_e(3*iim*jjm,llm)
185    REAL(rstd) :: q_e(3*iim*jjm,llm,nqtot)
186
187    INTEGER :: l,i,j,ij
188
189    SELECT CASE (TRIM(etat0_type))
190    CASE ('isothermal')
191       CALL compute_etat0_isothermal(iim*jjm, phis, ps, temp_i, ulon_i, ulat_i, q)
192       CALL compute_etat0_isothermal(3*iim*jjm, phis_e, ps_e, temp_e, ulon_e, ulat_e, q_e)
193    CASE ('temperature_profile')
194       CALL compute_etat0_temperature(iim*jjm, phis, ps, temp_i, ulon_i, ulat_i, q)
195       CALL compute_etat0_temperature(3*iim*jjm, phis_e, ps_e, temp_e, ulon_e, ulat_e, q_e)
196    CASE('jablonowsky06')
197       CALL compute_jablonowsky06(iim*jjm,lon_i,lat_i, phis, ps, temp_i, ulon_i, ulat_i)
198       CALL compute_jablonowsky06(3*iim*jjm,lon_e,lat_e, phis_e, ps_e, temp_e, ulon_e, ulat_e)
199    CASE('dcmip5')
200       CALL compute_dcmip5(iim*jjm,lon_i,lat_i, phis, ps, temp_i, ulon_i, ulat_i, q)
201       CALL compute_dcmip5(3*iim*jjm,lon_e,lat_e, phis_e, ps_e, temp_e, ulon_e, ulat_e, q_e)
202    CASE('williamson91.6')
203       CALL compute_w91_6(iim*jjm,lon_i,lat_i, phis, mass(:,1), temp_i(:,1), ulon_i(:,1), ulat_i(:,1))
204       CALL compute_w91_6(3*iim*jjm,lon_e,lat_e, phis_e, mass_e(:,1), temp_e(:,1), ulon_e(:,1), ulat_e(:,1))
205    END SELECT
206
207    CALL compute_wind_perp_from_lonlat_compound(ulon_e, ulat_e, u)
208
209  END SUBROUTINE compute_etat0_collocated
210
211!----------------------------- Resting isothermal state --------------------------------
212
213  SUBROUTINE getin_etat0_isothermal
214    etat0_temp=300
215    CALL getin("etat0_isothermal_temp",etat0_temp)
216  END SUBROUTINE getin_etat0_isothermal
217
218  SUBROUTINE compute_etat0_isothermal(ngrid, phis, ps, temp, ulon, ulat, q)
219    IMPLICIT NONE 
220    INTEGER, INTENT(IN)    :: ngrid
221    REAL(rstd),INTENT(OUT) :: phis(ngrid)
222    REAL(rstd),INTENT(OUT) :: ps(ngrid)
223    REAL(rstd),INTENT(OUT) :: temp(ngrid,llm)
224    REAL(rstd),INTENT(OUT) :: ulon(ngrid,llm)
225    REAL(rstd),INTENT(OUT) :: ulat(ngrid,llm)
226    REAL(rstd),INTENT(OUT) :: q(ngrid,llm,nqtot)
227    phis(:)=0
228    ps(:)=preff
229    temp(:,:)=etat0_temp
230    ulon(:,:)=0
231    ulat(:,:)=0
232    q(:,:,:)=0
233  END SUBROUTINE compute_etat0_isothermal
234
235END MODULE etat0_mod
Note: See TracBrowser for help on using the repository browser.