1 |
|
|
! |
2 |
|
|
MODULE oasis |
3 |
|
|
! |
4 |
|
|
! This module contains subroutines for initialization, sending and receiving |
5 |
|
|
! towards the coupler OASIS3. It also contains some parameters for the coupling. |
6 |
|
|
! |
7 |
|
|
! This module should always be compiled. With the coupler OASIS3 available the cpp key |
8 |
|
|
! CPP_COUPLE should be set and the entier of this file will then be compiled. |
9 |
|
|
! In a forced mode CPP_COUPLE should not be defined and the compilation ends before |
10 |
|
|
! the CONTAINS, without compiling the subroutines. |
11 |
|
|
! |
12 |
|
|
USE dimphy |
13 |
|
|
USE mod_phys_lmdz_para |
14 |
|
|
USE write_field_phy |
15 |
|
|
|
16 |
|
|
#ifdef CPP_COUPLE |
17 |
|
|
! Use of Oasis-MCT coupler |
18 |
|
|
#if defined CPP_OMCT |
19 |
|
|
USE mod_prism |
20 |
|
|
! Use of Oasis3 coupler |
21 |
|
|
#else |
22 |
|
|
USE mod_prism_proto |
23 |
|
|
USE mod_prism_def_partition_proto |
24 |
|
|
USE mod_prism_get_proto |
25 |
|
|
USE mod_prism_put_proto |
26 |
|
|
#endif |
27 |
|
|
#ifdef CPP_CPLOCNINCA |
28 |
|
|
USE incaoasis, ONLY : inforcv |
29 |
|
|
#endif |
30 |
|
|
#endif |
31 |
|
|
|
32 |
|
|
IMPLICIT NONE |
33 |
|
|
|
34 |
|
|
! Id for fields sent to ocean |
35 |
|
|
INTEGER, PARAMETER :: ids_tauxxu = 1 |
36 |
|
|
INTEGER, PARAMETER :: ids_tauyyu = 2 |
37 |
|
|
INTEGER, PARAMETER :: ids_tauzzu = 3 |
38 |
|
|
INTEGER, PARAMETER :: ids_tauxxv = 4 |
39 |
|
|
INTEGER, PARAMETER :: ids_tauyyv = 5 |
40 |
|
|
INTEGER, PARAMETER :: ids_tauzzv = 6 |
41 |
|
|
INTEGER, PARAMETER :: ids_windsp = 7 |
42 |
|
|
INTEGER, PARAMETER :: ids_shfice = 8 |
43 |
|
|
INTEGER, PARAMETER :: ids_shfoce = 9 |
44 |
|
|
INTEGER, PARAMETER :: ids_shftot = 10 |
45 |
|
|
INTEGER, PARAMETER :: ids_nsfice = 11 |
46 |
|
|
INTEGER, PARAMETER :: ids_nsfoce = 12 |
47 |
|
|
INTEGER, PARAMETER :: ids_nsftot = 13 |
48 |
|
|
INTEGER, PARAMETER :: ids_dflxdt = 14 |
49 |
|
|
INTEGER, PARAMETER :: ids_totrai = 15 |
50 |
|
|
INTEGER, PARAMETER :: ids_totsno = 16 |
51 |
|
|
INTEGER, PARAMETER :: ids_toteva = 17 |
52 |
|
|
INTEGER, PARAMETER :: ids_icevap = 18 |
53 |
|
|
INTEGER, PARAMETER :: ids_ocevap = 19 |
54 |
|
|
INTEGER, PARAMETER :: ids_calvin = 20 |
55 |
|
|
INTEGER, PARAMETER :: ids_liqrun = 21 |
56 |
|
|
INTEGER, PARAMETER :: ids_runcoa = 22 |
57 |
|
|
INTEGER, PARAMETER :: ids_rivflu = 23 |
58 |
|
|
INTEGER, PARAMETER :: ids_atmco2 = 24 |
59 |
|
|
INTEGER, PARAMETER :: ids_taumod = 25 |
60 |
|
|
INTEGER, PARAMETER :: ids_qraioc = 26 |
61 |
|
|
INTEGER, PARAMETER :: ids_qsnooc = 27 |
62 |
|
|
INTEGER, PARAMETER :: ids_qraiic = 28 |
63 |
|
|
INTEGER, PARAMETER :: ids_qsnoic = 29 |
64 |
|
|
INTEGER, PARAMETER :: ids_delta_sst = 30, ids_delta_sal = 31, ids_dter = 32, & |
65 |
|
|
ids_dser = 33, ids_dt_ds = 34 |
66 |
|
|
|
67 |
|
|
INTEGER, PARAMETER :: maxsend = 34 ! Maximum number of fields to send |
68 |
|
|
|
69 |
|
|
! Id for fields received from ocean |
70 |
|
|
|
71 |
|
|
INTEGER, PARAMETER :: idr_sisutw = 1 |
72 |
|
|
INTEGER, PARAMETER :: idr_icecov = 2 |
73 |
|
|
INTEGER, PARAMETER :: idr_icealw = 3 |
74 |
|
|
INTEGER, PARAMETER :: idr_icetem = 4 |
75 |
|
|
INTEGER, PARAMETER :: idr_curenx = 5 |
76 |
|
|
INTEGER, PARAMETER :: idr_cureny = 6 |
77 |
|
|
INTEGER, PARAMETER :: idr_curenz = 7 |
78 |
|
|
INTEGER, PARAMETER :: idr_oceco2 = 8 |
79 |
|
|
|
80 |
|
|
INTEGER, PARAMETER :: idr_sss = 9 |
81 |
|
|
! bulk salinity of the surface layer of the ocean, in ppt |
82 |
|
|
|
83 |
|
|
INTEGER, PARAMETER :: maxrecv = 9 ! Maximum number of fields to receive |
84 |
|
|
|
85 |
|
|
#ifdef CPP_CPLOCNINCA |
86 |
|
|
INTEGER, PARAMETER :: idr_ocedms = 1 |
87 |
|
|
INTEGER, PARAMETER :: maxrcv = 1 |
88 |
|
|
#endif |
89 |
|
|
|
90 |
|
|
TYPE, PUBLIC :: FLD_CPL ! Type for coupling field information |
91 |
|
|
CHARACTER(len = 8) :: name ! Name of the coupling field |
92 |
|
|
LOGICAL :: action ! To be exchanged or not |
93 |
|
|
INTEGER :: nid ! Id of the field |
94 |
|
|
END TYPE FLD_CPL |
95 |
|
|
|
96 |
|
|
TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend ! Information for sending coupling fields |
97 |
|
|
!$OMP THREADPRIVATE(infosend) |
98 |
|
|
TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv ! Information for receiving coupling fields |
99 |
|
|
!$OMP THREADPRIVATE(inforecv) |
100 |
|
|
|
101 |
|
|
LOGICAL,SAVE :: cpl_current |
102 |
|
|
!$OMP THREADPRIVATE(cpl_current) |
103 |
|
|
|
104 |
|
|
#ifdef CPP_COUPLE |
105 |
|
|
|
106 |
|
|
CONTAINS |
107 |
|
|
|
108 |
|
|
SUBROUTINE inicma |
109 |
|
|
!************************************************************************************ |
110 |
|
|
!**** *INICMA* - Initialize coupled mode communication for atmosphere |
111 |
|
|
! and exchange some initial information with Oasis |
112 |
|
|
! |
113 |
|
|
! Rewrite to take the PRISM/psmile library into account |
114 |
|
|
! LF 09/2003 |
115 |
|
|
! |
116 |
|
|
USE IOIPSL |
117 |
|
|
USE surface_data, ONLY : version_ocean |
118 |
|
|
USE carbon_cycle_mod, ONLY : carbon_cycle_cpl |
119 |
|
|
#ifdef CPP_XIOS |
120 |
|
|
USE wxios, ONLY : wxios_context_init |
121 |
|
|
USE xios |
122 |
|
|
#endif |
123 |
|
|
USE print_control_mod, ONLY: lunout |
124 |
|
|
USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured, regular_lonlat |
125 |
|
|
USE geometry_mod, ONLY: ind_cell_glo |
126 |
|
|
USE mod_phys_lmdz_mpi_data, ONLY: klon_mpi_para_nb |
127 |
|
|
use config_ocean_skin_m, only: activate_ocean_skin |
128 |
|
|
|
129 |
|
|
! Local variables |
130 |
|
|
!************************************************************************************ |
131 |
|
|
INTEGER :: comp_id |
132 |
|
|
INTEGER :: ierror, il_commlocal |
133 |
|
|
INTEGER :: il_part_id |
134 |
|
|
INTEGER, ALLOCATABLE :: ig_paral(:) |
135 |
|
|
INTEGER, DIMENSION(2) :: il_var_nodims |
136 |
|
|
INTEGER, DIMENSION(4) :: il_var_actual_shape |
137 |
|
|
INTEGER :: il_var_type |
138 |
|
|
INTEGER :: jf |
139 |
|
|
CHARACTER (len = 6) :: clmodnam |
140 |
|
|
CHARACTER (len = 20) :: modname = 'inicma' |
141 |
|
|
CHARACTER (len = 80) :: abort_message |
142 |
|
|
LOGICAL, SAVE :: cpl_current_omp |
143 |
|
|
|
144 |
|
|
!* 1. Initializations |
145 |
|
|
! --------------- |
146 |
|
|
!************************************************************************************ |
147 |
|
|
WRITE(lunout,*) ' ' |
148 |
|
|
WRITE(lunout,*) ' ' |
149 |
|
|
WRITE(lunout,*) ' ROUTINE INICMA' |
150 |
|
|
WRITE(lunout,*) ' **************' |
151 |
|
|
WRITE(lunout,*) ' ' |
152 |
|
|
WRITE(lunout,*) ' ' |
153 |
|
|
|
154 |
|
|
! |
155 |
|
|
! Define the model name |
156 |
|
|
! |
157 |
|
|
IF (grid_type==unstructured) THEN |
158 |
|
|
clmodnam = 'icosa' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp |
159 |
|
|
ELSE IF (grid_type==regular_lonlat) THEN |
160 |
|
|
clmodnam = 'LMDZ' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp |
161 |
|
|
ELSE |
162 |
|
|
abort_message='Pb : type of grid unknown' |
163 |
|
|
CALL abort_physic(modname,abort_message,1) |
164 |
|
|
ENDIF |
165 |
|
|
|
166 |
|
|
|
167 |
|
|
!************************************************************************************ |
168 |
|
|
! Define if coupling ocean currents or not |
169 |
|
|
!************************************************************************************ |
170 |
|
|
!$OMP MASTER |
171 |
|
|
cpl_current_omp = .FALSE. |
172 |
|
|
CALL getin('cpl_current', cpl_current_omp) |
173 |
|
|
!$OMP END MASTER |
174 |
|
|
!$OMP BARRIER |
175 |
|
|
cpl_current = cpl_current_omp |
176 |
|
|
WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current |
177 |
|
|
|
178 |
|
|
!************************************************************************************ |
179 |
|
|
! Define coupling variables |
180 |
|
|
!************************************************************************************ |
181 |
|
|
|
182 |
|
|
! Atmospheric variables to send |
183 |
|
|
|
184 |
|
|
!$OMP MASTER |
185 |
|
|
infosend(:)%action = .FALSE. |
186 |
|
|
|
187 |
|
|
infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU' |
188 |
|
|
infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU' |
189 |
|
|
infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU' |
190 |
|
|
infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV' |
191 |
|
|
infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV' |
192 |
|
|
infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV' |
193 |
|
|
infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP' |
194 |
|
|
infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE' |
195 |
|
|
infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE' |
196 |
|
|
infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT' |
197 |
|
|
infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN' |
198 |
|
|
|
199 |
|
|
if (activate_ocean_skin == 2) then |
200 |
|
|
infosend(ids_delta_sst)%action = .TRUE. |
201 |
|
|
infosend(ids_delta_sst)%name = 'CODELSST' |
202 |
|
|
infosend(ids_delta_sal)%action = .TRUE. |
203 |
|
|
infosend(ids_delta_sal)%name = 'CODELSSS' |
204 |
|
|
infosend(ids_dter)%action = .TRUE. |
205 |
|
|
infosend(ids_dter)%name = 'CODELTER' |
206 |
|
|
infosend(ids_dser)%action = .TRUE. |
207 |
|
|
infosend(ids_dser)%name = 'CODELSER' |
208 |
|
|
infosend(ids_dt_ds)%action = .TRUE. |
209 |
|
|
infosend(ids_dt_ds)%name = 'CODTDS' |
210 |
|
|
end if |
211 |
|
|
|
212 |
|
|
IF (version_ocean=='nemo') THEN |
213 |
|
|
infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX' |
214 |
|
|
infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX' |
215 |
|
|
infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI' |
216 |
|
|
infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO' |
217 |
|
|
infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA' |
218 |
|
|
infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP' |
219 |
|
|
infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN' |
220 |
|
|
infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD' |
221 |
|
|
IF (carbon_cycle_cpl) THEN |
222 |
|
|
infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2' |
223 |
|
|
ENDIF |
224 |
|
|
infosend(ids_qraioc)%action = .TRUE. ; infosend(ids_qraioc)%name = 'COQRAIOC' |
225 |
|
|
infosend(ids_qsnooc)%action = .TRUE. ; infosend(ids_qsnooc)%name = 'COQSNOOC' |
226 |
|
|
infosend(ids_qraiic)%action = .TRUE. ; infosend(ids_qraiic)%name = 'COQRAIIC' |
227 |
|
|
infosend(ids_qsnoic)%action = .TRUE. ; infosend(ids_qsnoic)%name = 'COQSNOIC' |
228 |
|
|
|
229 |
|
|
ELSE IF (version_ocean=='opa8') THEN |
230 |
|
|
infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE' |
231 |
|
|
infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE' |
232 |
|
|
infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE' |
233 |
|
|
infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE' |
234 |
|
|
infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU' |
235 |
|
|
infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU' |
236 |
|
|
infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA' |
237 |
|
|
infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU' |
238 |
|
|
ENDIF |
239 |
|
|
|
240 |
|
|
! Oceanic variables to receive |
241 |
|
|
|
242 |
|
|
inforecv(:)%action = .FALSE. |
243 |
|
|
|
244 |
|
|
inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW' |
245 |
|
|
inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV' |
246 |
|
|
inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW' |
247 |
|
|
inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW' |
248 |
|
|
|
249 |
|
|
if (activate_ocean_skin >= 1) then |
250 |
|
|
inforecv(idr_sss)%action = .TRUE. |
251 |
|
|
inforecv(idr_sss)%name = 'SISUSALW' |
252 |
|
|
end if |
253 |
|
|
|
254 |
|
|
IF (cpl_current ) THEN |
255 |
|
|
inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX' |
256 |
|
|
inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY' |
257 |
|
|
inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ' |
258 |
|
|
ENDIF |
259 |
|
|
|
260 |
|
|
IF (carbon_cycle_cpl ) THEN |
261 |
|
|
inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX' |
262 |
|
|
ENDIF |
263 |
|
|
#ifdef CPP_CPLOCNINCA |
264 |
|
|
inforcv(idr_ocedms)%action = .TRUE. ; inforcv(idr_ocedms)%name = 'SIDMSFLX' |
265 |
|
|
#endif |
266 |
|
|
|
267 |
|
|
!************************************************************************************ |
268 |
|
|
! Here we go: psmile initialisation |
269 |
|
|
!************************************************************************************ |
270 |
|
|
IF (is_sequential) THEN |
271 |
|
|
CALL prism_init_comp_proto (comp_id, clmodnam, ierror) |
272 |
|
|
|
273 |
|
|
IF (ierror .NE. PRISM_Ok) THEN |
274 |
|
|
abort_message=' Probleme init dans prism_init_comp ' |
275 |
|
|
CALL abort_physic(modname,abort_message,1) |
276 |
|
|
ELSE |
277 |
|
|
WRITE(lunout,*) 'inicma : init psmile ok ' |
278 |
|
|
ENDIF |
279 |
|
|
ENDIF |
280 |
|
|
|
281 |
|
|
CALL prism_get_localcomm_proto (il_commlocal, ierror) |
282 |
|
|
!************************************************************************************ |
283 |
|
|
! Domain decomposition |
284 |
|
|
!************************************************************************************ |
285 |
|
|
IF (grid_type==unstructured) THEN |
286 |
|
|
|
287 |
|
|
ALLOCATE( ig_paral(klon_mpi_para_nb(mpi_rank) + 2) ) |
288 |
|
|
|
289 |
|
|
ig_paral(1) = 4 ! points partition for // |
290 |
|
|
ig_paral(2) = klon_mpi_para_nb(mpi_rank) ! nb of local cells |
291 |
|
|
|
292 |
|
|
DO jf=1, klon_mpi_para_nb(mpi_rank) |
293 |
|
|
ig_paral(2+jf) = ind_cell_glo(jf) |
294 |
|
|
ENDDO |
295 |
|
|
|
296 |
|
|
ELSE IF (grid_type==regular_lonlat) THEN |
297 |
|
|
|
298 |
|
|
ALLOCATE( ig_paral(3) ) |
299 |
|
|
|
300 |
|
|
ig_paral(1) = 1 ! apple partition for // |
301 |
|
|
ig_paral(2) = (jj_begin-1)*nbp_lon+ii_begin-1 ! offset |
302 |
|
|
ig_paral(3) = (jj_end*nbp_lon+ii_end) - (jj_begin*nbp_lon+ii_begin) + 1 |
303 |
|
|
|
304 |
|
|
IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1 |
305 |
|
|
ELSE |
306 |
|
|
abort_message='Pb : type of grid unknown' |
307 |
|
|
CALL abort_physic(modname,abort_message,1) |
308 |
|
|
ENDIF |
309 |
|
|
|
310 |
|
|
|
311 |
|
|
WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3) |
312 |
|
|
|
313 |
|
|
ierror=PRISM_Ok |
314 |
|
|
CALL prism_def_partition_proto (il_part_id, ig_paral, ierror) |
315 |
|
|
|
316 |
|
|
IF (ierror .NE. PRISM_Ok) THEN |
317 |
|
|
abort_message=' Probleme dans prism_def_partition ' |
318 |
|
|
CALL abort_physic(modname,abort_message,1) |
319 |
|
|
ELSE |
320 |
|
|
WRITE(lunout,*) 'inicma : decomposition domaine psmile ok ' |
321 |
|
|
ENDIF |
322 |
|
|
|
323 |
|
|
il_var_nodims(1) = 2 ! rank of field array (1d or 2d) |
324 |
|
|
il_var_nodims(2) = 1 ! always 1 in current oasis version" doc oasis3mct p18 |
325 |
|
|
|
326 |
|
|
il_var_actual_shape(1) = 1 ! min of 1st dimension (always 1) |
327 |
|
|
il_var_actual_shape(2) = nbp_lon ! max of 1st dimension |
328 |
|
|
il_var_actual_shape(3) = 1 ! min of 2nd dimension (always 1) |
329 |
|
|
il_var_actual_shape(4) = nbp_lat ! max of 2nd dimension |
330 |
|
|
|
331 |
|
|
il_var_type = PRISM_Real |
332 |
|
|
|
333 |
|
|
!************************************************************************************ |
334 |
|
|
! Oceanic Fields to receive |
335 |
|
|
! Loop over all possible variables |
336 |
|
|
!************************************************************************************ |
337 |
|
|
DO jf=1, maxrecv |
338 |
|
|
IF (inforecv(jf)%action) THEN |
339 |
|
|
CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, & |
340 |
|
|
il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, & |
341 |
|
|
ierror) |
342 |
|
|
IF (ierror .NE. PRISM_Ok) THEN |
343 |
|
|
WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',& |
344 |
|
|
inforecv(jf)%name |
345 |
|
|
abort_message=' Problem in call to prism_def_var_proto for fields to receive' |
346 |
|
|
CALL abort_physic(modname,abort_message,1) |
347 |
|
|
ENDIF |
348 |
|
|
ENDIF |
349 |
|
|
END DO |
350 |
|
|
|
351 |
|
|
! Now, if also coupling CPL with INCA, initialize here fields to be exchanged. |
352 |
|
|
#ifdef CPP_CPLOCNINCA |
353 |
|
|
DO jf=1,maxrcv |
354 |
|
|
IF (inforcv(jf)%action) THEN |
355 |
|
|
CALL prism_def_var_proto(inforcv(jf)%nid, inforcv(jf)%name, il_part_id, & |
356 |
|
|
il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, & |
357 |
|
|
ierror) |
358 |
|
|
IF (ierror .NE. PRISM_Ok) THEN |
359 |
|
|
WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',& |
360 |
|
|
inforcv(jf)%name |
361 |
|
|
abort_message=' Problem in call to prism_def_var_proto for fields to receive' |
362 |
|
|
CALL abort_physic(modname,abort_message,1) |
363 |
|
|
ENDIF |
364 |
|
|
ENDIF |
365 |
|
|
END DO |
366 |
|
|
#endif |
367 |
|
|
|
368 |
|
|
!************************************************************************************ |
369 |
|
|
! Atmospheric Fields to send |
370 |
|
|
! Loop over all possible variables |
371 |
|
|
!************************************************************************************ |
372 |
|
|
DO jf=1,maxsend |
373 |
|
|
IF (infosend(jf)%action) THEN |
374 |
|
|
CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, & |
375 |
|
|
il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, & |
376 |
|
|
ierror) |
377 |
|
|
IF (ierror .NE. PRISM_Ok) THEN |
378 |
|
|
WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',& |
379 |
|
|
infosend(jf)%name |
380 |
|
|
abort_message=' Problem in call to prism_def_var_proto for fields to send' |
381 |
|
|
CALL abort_physic(modname,abort_message,1) |
382 |
|
|
ENDIF |
383 |
|
|
ENDIF |
384 |
|
|
END DO |
385 |
|
|
|
386 |
|
|
!************************************************************************************ |
387 |
|
|
! End definition |
388 |
|
|
!************************************************************************************ |
389 |
|
|
#ifdef CPP_XIOS |
390 |
|
|
CALL xios_oasis_enddef() |
391 |
|
|
#endif |
392 |
|
|
CALL prism_enddef_proto(ierror) |
393 |
|
|
IF (ierror .NE. PRISM_Ok) THEN |
394 |
|
|
abort_message=' Problem in call to prism_endef_proto' |
395 |
|
|
CALL abort_physic(modname,abort_message,1) |
396 |
|
|
ELSE |
397 |
|
|
WRITE(lunout,*) 'inicma : endef psmile ok ' |
398 |
|
|
ENDIF |
399 |
|
|
|
400 |
|
|
#ifdef CPP_XIOS |
401 |
|
|
! CALL wxios_context_init() |
402 |
|
|
#endif |
403 |
|
|
|
404 |
|
|
!$OMP END MASTER |
405 |
|
|
|
406 |
|
|
END SUBROUTINE inicma |
407 |
|
|
|
408 |
|
|
! |
409 |
|
|
!************************************************************************************ |
410 |
|
|
! |
411 |
|
|
|
412 |
|
|
SUBROUTINE fromcpl(ktime, tab_get) |
413 |
|
|
! ====================================================================== |
414 |
|
|
! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST |
415 |
|
|
! and Sea-Ice provided by the coupler. Adaptation to psmile library |
416 |
|
|
!====================================================================== |
417 |
|
|
! |
418 |
|
|
USE print_control_mod, ONLY: lunout |
419 |
|
|
USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat |
420 |
|
|
! Input arguments |
421 |
|
|
!************************************************************************************ |
422 |
|
|
INTEGER, INTENT(IN) :: ktime |
423 |
|
|
|
424 |
|
|
! Output arguments |
425 |
|
|
!************************************************************************************ |
426 |
|
|
REAL, DIMENSION(nbp_lon, jj_nb,maxrecv), INTENT(OUT) :: tab_get |
427 |
|
|
|
428 |
|
|
! Local variables |
429 |
|
|
!************************************************************************************ |
430 |
|
|
INTEGER :: ierror, i |
431 |
|
|
INTEGER :: istart,iend |
432 |
|
|
CHARACTER (len = 20) :: modname = 'fromcpl' |
433 |
|
|
CHARACTER (len = 80) :: abort_message |
434 |
|
|
REAL, DIMENSION(nbp_lon*jj_nb) :: field |
435 |
|
|
|
436 |
|
|
!************************************************************************************ |
437 |
|
|
WRITE (lunout,*) ' ' |
438 |
|
|
WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime |
439 |
|
|
WRITE (lunout,*) ' ' |
440 |
|
|
|
441 |
|
|
istart=ii_begin |
442 |
|
|
IF (is_south_pole_dyn) THEN |
443 |
|
|
iend=(jj_end-jj_begin)*nbp_lon+nbp_lon |
444 |
|
|
ELSE |
445 |
|
|
iend=(jj_end-jj_begin)*nbp_lon+ii_end |
446 |
|
|
ENDIF |
447 |
|
|
|
448 |
|
|
DO i = 1, maxrecv |
449 |
|
|
IF (inforecv(i)%action .AND. inforecv(i)%nid .NE. -1) THEN |
450 |
|
|
field(:) = -99999. |
451 |
|
|
CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror) |
452 |
|
|
tab_get(:,:,i) = RESHAPE(field(:),(/nbp_lon,jj_nb/)) |
453 |
|
|
|
454 |
|
|
IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. & |
455 |
|
|
ierror.NE.PRISM_FromRest & |
456 |
|
|
.AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut & |
457 |
|
|
.AND. ierror.NE.PRISM_FromRestOut) THEN |
458 |
|
|
WRITE (lunout,*) 'Error with receiving filed : ', inforecv(i)%name, ktime |
459 |
|
|
abort_message=' Problem in prism_get_proto ' |
460 |
|
|
CALL abort_physic(modname,abort_message,1) |
461 |
|
|
ENDIF |
462 |
|
|
ENDIF |
463 |
|
|
END DO |
464 |
|
|
|
465 |
|
|
|
466 |
|
|
END SUBROUTINE fromcpl |
467 |
|
|
|
468 |
|
|
! |
469 |
|
|
!************************************************************************************ |
470 |
|
|
! |
471 |
|
|
|
472 |
|
|
SUBROUTINE intocpl(ktime, last, tab_put) |
473 |
|
|
! ====================================================================== |
474 |
|
|
! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the |
475 |
|
|
! atmospheric coupling fields to the coupler with the psmile library. |
476 |
|
|
! IF last time step, writes output fields to binary files. |
477 |
|
|
! ====================================================================== |
478 |
|
|
! |
479 |
|
|
! |
480 |
|
|
USE print_control_mod, ONLY: lunout |
481 |
|
|
USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat |
482 |
|
|
! Input arguments |
483 |
|
|
!************************************************************************************ |
484 |
|
|
INTEGER, INTENT(IN) :: ktime |
485 |
|
|
LOGICAL, INTENT(IN) :: last |
486 |
|
|
REAL, DIMENSION(nbp_lon, jj_nb, maxsend), INTENT(IN) :: tab_put |
487 |
|
|
|
488 |
|
|
! Local variables |
489 |
|
|
!************************************************************************************ |
490 |
|
|
LOGICAL :: checkout |
491 |
|
|
INTEGER :: istart,iend |
492 |
|
|
INTEGER :: wstart,wend |
493 |
|
|
INTEGER :: ierror, i |
494 |
|
|
REAL, DIMENSION(nbp_lon*jj_nb) :: field |
495 |
|
|
CHARACTER (len = 20),PARAMETER :: modname = 'intocpl' |
496 |
|
|
CHARACTER (len = 80) :: abort_message |
497 |
|
|
|
498 |
|
|
!************************************************************************************ |
499 |
|
|
checkout=.FALSE. |
500 |
|
|
|
501 |
|
|
WRITE(lunout,*) ' ' |
502 |
|
|
WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime |
503 |
|
|
WRITE(lunout,*) 'last = ', last |
504 |
|
|
WRITE(lunout,*) |
505 |
|
|
|
506 |
|
|
|
507 |
|
|
istart=ii_begin |
508 |
|
|
IF (is_south_pole_dyn) THEN |
509 |
|
|
iend=(jj_end-jj_begin)*nbp_lon+nbp_lon |
510 |
|
|
ELSE |
511 |
|
|
iend=(jj_end-jj_begin)*nbp_lon+ii_end |
512 |
|
|
ENDIF |
513 |
|
|
|
514 |
|
|
IF (checkout) THEN |
515 |
|
|
wstart=istart |
516 |
|
|
wend=iend |
517 |
|
|
IF (is_north_pole_dyn) wstart=istart+nbp_lon-1 |
518 |
|
|
IF (is_south_pole_dyn) wend=iend-nbp_lon+1 |
519 |
|
|
|
520 |
|
|
DO i = 1, maxsend |
521 |
|
|
IF (infosend(i)%action) THEN |
522 |
|
|
field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/)) |
523 |
|
|
CALL writefield_phy(infosend(i)%name,field(wstart:wend),1) |
524 |
|
|
END IF |
525 |
|
|
END DO |
526 |
|
|
END IF |
527 |
|
|
|
528 |
|
|
!************************************************************************************ |
529 |
|
|
! PRISM_PUT |
530 |
|
|
!************************************************************************************ |
531 |
|
|
|
532 |
|
|
DO i = 1, maxsend |
533 |
|
|
IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) THEN |
534 |
|
|
field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/)) |
535 |
|
|
CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror) |
536 |
|
|
|
537 |
|
|
IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest & |
538 |
|
|
.AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. & |
539 |
|
|
ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN |
540 |
|
|
WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime |
541 |
|
|
abort_message=' Problem in prism_put_proto ' |
542 |
|
|
CALL abort_physic(modname,abort_message,1) |
543 |
|
|
ENDIF |
544 |
|
|
ENDIF |
545 |
|
|
END DO |
546 |
|
|
|
547 |
|
|
!************************************************************************************ |
548 |
|
|
! Finalize PSMILE for the case is_sequential, if parallel finalization is done |
549 |
|
|
! from Finalize_parallel in dyn3dpar/parallel.F90 |
550 |
|
|
!************************************************************************************ |
551 |
|
|
|
552 |
|
|
IF (last) THEN |
553 |
|
|
IF (is_sequential) THEN |
554 |
|
|
CALL prism_terminate_proto(ierror) |
555 |
|
|
IF (ierror .NE. PRISM_Ok) THEN |
556 |
|
|
abort_message=' Problem in prism_terminate_proto ' |
557 |
|
|
CALL abort_physic(modname,abort_message,1) |
558 |
|
|
ENDIF |
559 |
|
|
ENDIF |
560 |
|
|
ENDIF |
561 |
|
|
|
562 |
|
|
|
563 |
|
|
END SUBROUTINE intocpl |
564 |
|
|
|
565 |
|
|
#endif |
566 |
|
|
|
567 |
|
|
END MODULE oasis |