Context Navigation

oasis.F90 @ 3470

Last change on this file since 3470 was 1274, checked in by Laurent Fairhead, 15 years ago

possibilite de passer le module du stress du vent (activation ou pas via la namcouple Oasis)
petite correction OpenMP

Property svn:eol-style set to native
Property svn:executable set to *
Property svn:keywords set to Author Date Id Revision

File size: 17.9 KB

Line
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 mod_prism_proto
18	USE mod_prism_def_partition_proto
19	USE mod_prism_get_proto
20	USE mod_prism_put_proto
21	#endif
22
23	IMPLICIT NONE
24
25	! Id for fields sent to ocean
26	INTEGER, PARAMETER :: ids_tauxxu = 1
27	INTEGER, PARAMETER :: ids_tauyyu = 2
28	INTEGER, PARAMETER :: ids_tauzzu = 3
29	INTEGER, PARAMETER :: ids_tauxxv = 4
30	INTEGER, PARAMETER :: ids_tauyyv = 5
31	INTEGER, PARAMETER :: ids_tauzzv = 6
32	INTEGER, PARAMETER :: ids_windsp = 7
33	INTEGER, PARAMETER :: ids_shfice = 8
34	INTEGER, PARAMETER :: ids_shfoce = 9
35	INTEGER, PARAMETER :: ids_shftot = 10
36	INTEGER, PARAMETER :: ids_nsfice = 11
37	INTEGER, PARAMETER :: ids_nsfoce = 12
38	INTEGER, PARAMETER :: ids_nsftot = 13
39	INTEGER, PARAMETER :: ids_dflxdt = 14
40	INTEGER, PARAMETER :: ids_totrai = 15
41	INTEGER, PARAMETER :: ids_totsno = 16
42	INTEGER, PARAMETER :: ids_toteva = 17
43	INTEGER, PARAMETER :: ids_icevap = 18
44	INTEGER, PARAMETER :: ids_ocevap = 19
45	INTEGER, PARAMETER :: ids_calvin = 20
46	INTEGER, PARAMETER :: ids_liqrun = 21
47	INTEGER, PARAMETER :: ids_runcoa = 22
48	INTEGER, PARAMETER :: ids_rivflu = 23
49	INTEGER, PARAMETER :: ids_atmco2 = 24
50	INTEGER, PARAMETER :: ids_taumod = 25
51	INTEGER, PARAMETER :: maxsend = 25 ! Maximum number of fields to send
52
53	! Id for fields received from ocean
54	INTEGER, PARAMETER :: idr_sisutw = 1
55	INTEGER, PARAMETER :: idr_icecov = 2
56	INTEGER, PARAMETER :: idr_icealw = 3
57	INTEGER, PARAMETER :: idr_icetem = 4
58	INTEGER, PARAMETER :: idr_curenx = 5
59	INTEGER, PARAMETER :: idr_cureny = 6
60	INTEGER, PARAMETER :: idr_curenz = 7
61	INTEGER, PARAMETER :: idr_oceco2 = 8
62	INTEGER, PARAMETER :: maxrecv = 8 ! Maximum number of fields to receive
63
64
65	TYPE, PUBLIC :: FLD_CPL ! Type for coupling field information
66	CHARACTER(len = 8) :: name ! Name of the coupling field
67	LOGICAL :: action ! To be exchanged or not
68	INTEGER :: nid ! Id of the field
69	END TYPE FLD_CPL
70
71	TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend ! Information for sending coupling fields
72	TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv ! Information for receiving coupling fields
73
74	LOGICAL,SAVE :: cpl_current
75	!$OMP THREADPRIVATE(cpl_current)
76
77	#ifdef CPP_COUPLE
78
79	CONTAINS
80
81	SUBROUTINE inicma
82	!************************************************************************************
83	!**** INICMA - Initialize coupled mode communication for atmosphere
84	! and exchange some initial information with Oasis
85	!
86	! Rewrite to take the PRISM/psmile library into account
87	! LF 09/2003
88	!
89	USE IOIPSL
90	USE surface_data, ONLY : version_ocean
91	USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
92
93	INCLUDE "dimensions.h"
94	INCLUDE "iniprint.h"
95
96	! Local variables
97	!************************************************************************************
98	INTEGER :: comp_id
99	INTEGER :: ierror, il_commlocal
100	INTEGER :: il_part_id
101	INTEGER, DIMENSION(3) :: ig_paral
102	INTEGER, DIMENSION(2) :: il_var_nodims
103	INTEGER, DIMENSION(4) :: il_var_actual_shape
104	INTEGER :: il_var_type
105	INTEGER :: jf
106	CHARACTER (len = 6) :: clmodnam
107	CHARACTER (len = 20) :: modname = 'inicma'
108	CHARACTER (len = 80) :: abort_message
109	LOGICAL :: cpl_current_omp
110
111	!* 1. Initializations
112	! ---------------
113	!************************************************************************************
114	WRITE(lunout,*) ' '
115	WRITE(lunout,*) ' '
116	WRITE(lunout,*) ' ROUTINE INICMA'
117	WRITE(lunout,) ' *************'
118	WRITE(lunout,*) ' '
119	WRITE(lunout,*) ' '
120
121	!
122	! Define the model name
123	!
124	clmodnam = 'lmdz.x' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
125
126
127	!************************************************************************************
128	! Define if coupling ocean currents or not
129	!************************************************************************************
130	!$OMP MASTER
131	cpl_current_omp = .FALSE.
132	CALL getin('cpl_current', cpl_current_omp)
133	!$OMP END MASTER
134	!$OMP BARRIER
135	cpl_current = cpl_current_omp
136	WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current
137
138	!************************************************************************************
139	! Define coupling variables
140	!************************************************************************************
141
142	! Atmospheric variables to send
143
144	!$OMP MASTER
145	infosend(:)%action = .FALSE.
146
147	infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU'
148	infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU'
149	infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU'
150	infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV'
151	infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV'
152	infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV'
153	infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP'
154	infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE'
155	infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE'
156	infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT'
157	infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN'
158
159	IF (version_ocean=='nemo') THEN
160	infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX'
161	infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX'
162	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI'
163	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO'
164	infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA'
165	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP'
166	infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN'
167	infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD'
168	IF (carbon_cycle_cpl) THEN
169	infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2'
170	ENDIF
171
172	ELSE IF (version_ocean=='opa8') THEN
173	infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE'
174	infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE'
175	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE'
176	infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE'
177	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU'
178	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU'
179	infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA'
180	infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU'
181	ENDIF
182
183	! Oceanic variables to receive
184
185	inforecv(:)%action = .FALSE.
186
187	inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW'
188	inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV'
189	inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW'
190	inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW'
191
192	IF (cpl_current ) THEN
193	inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX'
194	inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY'
195	inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ'
196	ENDIF
197
198	IF (carbon_cycle_cpl ) THEN
199	inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX'
200	ENDIF
201
202	!************************************************************************************
203	! Here we go: psmile initialisation
204	!************************************************************************************
205	IF (is_sequential) THEN
206	CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
207
208	IF (ierror .NE. PRISM_Ok) THEN
209	abort_message=' Probleme init dans prism_init_comp '
210	CALL abort_gcm(modname,abort_message,1)
211	ELSE
212	WRITE(lunout,*) 'inicma : init psmile ok '
213	ENDIF
214	ENDIF
215
216	CALL prism_get_localcomm_proto (il_commlocal, ierror)
217	!************************************************************************************
218	! Domain decomposition
219	!************************************************************************************
220	ig_paral(1) = 1 ! apple partition for //
221	ig_paral(2) = (jj_begin-1)*iim+ii_begin-1 ! offset
222	ig_paral(3) = (jj_endiim+ii_end) - (jj_beginiim+ii_begin) + 1
223
224	IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
225	WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
226
227	ierror=PRISM_Ok
228	CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
229
230	IF (ierror .NE. PRISM_Ok) THEN
231	abort_message=' Probleme dans prism_def_partition '
232	CALL abort_gcm(modname,abort_message,1)
233	ELSE
234	WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
235	ENDIF
236
237	il_var_nodims(1) = 2
238	il_var_nodims(2) = 1
239
240	il_var_actual_shape(1) = 1
241	il_var_actual_shape(2) = iim
242	il_var_actual_shape(3) = 1
243	il_var_actual_shape(4) = jjm+1
244
245	il_var_type = PRISM_Real
246
247	!************************************************************************************
248	! Oceanic Fields to receive
249	! Loop over all possible variables
250	!************************************************************************************
251	DO jf=1, maxrecv
252	IF (inforecv(jf)%action) THEN
253	CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, &
254	il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
255	ierror)
256	IF (ierror .NE. PRISM_Ok) THEN
257	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
258	inforecv(jf)%name
259	abort_message=' Problem in call to prism_def_var_proto for fields to receive'
260	CALL abort_gcm(modname,abort_message,1)
261	ENDIF
262	ENDIF
263	END DO
264
265	!************************************************************************************
266	! Atmospheric Fields to send
267	! Loop over all possible variables
268	!************************************************************************************
269	DO jf=1,maxsend
270	IF (infosend(jf)%action) THEN
271	CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
272	il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
273	ierror)
274	IF (ierror .NE. PRISM_Ok) THEN
275	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
276	infosend(jf)%name
277	abort_message=' Problem in call to prism_def_var_proto for fields to send'
278	CALL abort_gcm(modname,abort_message,1)
279	ENDIF
280	ENDIF
281	END DO
282
283	!************************************************************************************
284	! End definition
285	!************************************************************************************
286	CALL prism_enddef_proto(ierror)
287	IF (ierror .NE. PRISM_Ok) THEN
288	abort_message=' Problem in call to prism_endef_proto'
289	CALL abort_gcm(modname,abort_message,1)
290	ELSE
291	WRITE(lunout,*) 'inicma : endef psmile ok '
292	ENDIF
293
294	!$OMP END MASTER
295
296	END SUBROUTINE inicma
297
298	!
299	!************************************************************************************
300	!
301
302	SUBROUTINE fromcpl(ktime, tab_get)
303	! ======================================================================
304	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
305	! and Sea-Ice provided by the coupler. Adaptation to psmile library
306	!======================================================================
307	!
308	INCLUDE "dimensions.h"
309	INCLUDE "iniprint.h"
310	! Input arguments
311	!************************************************************************************
312	INTEGER, INTENT(IN) :: ktime
313
314	! Output arguments
315	!************************************************************************************
316	REAL, DIMENSION(iim, jj_nb,maxrecv), INTENT(OUT) :: tab_get
317
318	! Local variables
319	!************************************************************************************
320	INTEGER :: ierror, i
321	INTEGER :: istart,iend
322	CHARACTER (len = 20) :: modname = 'fromcpl'
323	CHARACTER (len = 80) :: abort_message
324	REAL, DIMENSION(iim*jj_nb) :: field
325
326	!************************************************************************************
327	WRITE (lunout,*) ' '
328	WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
329	WRITE (lunout,*) ' '
330
331	istart=ii_begin
332	IF (is_south_pole) THEN
333	iend=(jj_end-jj_begin)*iim+iim
334	ELSE
335	iend=(jj_end-jj_begin)*iim+ii_end
336	ENDIF
337
338	DO i = 1, maxrecv
339	IF (inforecv(i)%action) THEN
340	field(:) = -99999.
341	CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror)
342	tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
343
344	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
345	ierror.NE.PRISM_FromRest &
346	.AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
347	.AND. ierror.NE.PRISM_FromRestOut) THEN
348	WRITE (lunout,*) 'Error with receiving filed : ', inforecv(i)%name, ktime
349	abort_message=' Problem in prism_get_proto '
350	CALL abort_gcm(modname,abort_message,1)
351	ENDIF
352	ENDIF
353	END DO
354
355
356	END SUBROUTINE fromcpl
357
358	!
359	!************************************************************************************
360	!
361
362	SUBROUTINE intocpl(ktime, last, tab_put)
363	! ======================================================================
364	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
365	! atmospheric coupling fields to the coupler with the psmile library.
366	! IF last time step, writes output fields to binary files.
367	! ======================================================================
368	!
369	!
370	INCLUDE "dimensions.h"
371	INCLUDE "iniprint.h"
372	! Input arguments
373	!************************************************************************************
374	INTEGER, INTENT(IN) :: ktime
375	LOGICAL, INTENT(IN) :: last
376	REAL, DIMENSION(iim, jj_nb, maxsend), INTENT(IN) :: tab_put
377
378	! Local variables
379	!************************************************************************************
380	LOGICAL :: checkout
381	INTEGER :: istart,iend
382	INTEGER :: wstart,wend
383	INTEGER :: ierror, i
384	REAL, DIMENSION(iim*jj_nb) :: field
385	CHARACTER (len = 20),PARAMETER :: modname = 'intocpl'
386	CHARACTER (len = 80) :: abort_message
387
388	!************************************************************************************
389	checkout=.FALSE.
390
391	WRITE(lunout,*) ' '
392	WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
393	WRITE(lunout,*) 'last = ', last
394	WRITE(lunout,*)
395
396
397	istart=ii_begin
398	IF (is_south_pole) THEN
399	iend=(jj_end-jj_begin)*iim+iim
400	ELSE
401	iend=(jj_end-jj_begin)*iim+ii_end
402	ENDIF
403
404	IF (checkout) THEN
405	wstart=istart
406	wend=iend
407	IF (is_north_pole) wstart=istart+iim-1
408	IF (is_south_pole) wend=iend-iim+1
409
410	DO i = 1, maxsend
411	IF (infosend(i)%action) THEN
412	field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
413	CALL writefield_phy(infosend(i)%name,field(wstart:wend),1)
414	END IF
415	END DO
416	END IF
417
418	!************************************************************************************
419	! PRISM_PUT
420	!************************************************************************************
421
422	DO i = 1, maxsend
423	IF (infosend(i)%action) THEN
424	field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
425	CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror)
426
427	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
428	.AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
429	ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
430	WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime
431	abort_message=' Problem in prism_put_proto '
432	CALL abort_gcm(modname,abort_message,1)
433	ENDIF
434	ENDIF
435	END DO
436
437	!************************************************************************************
438	! Finalize PSMILE for the case is_sequential, if parallel finalization is done
439	! from Finalize_parallel in dyn3dpar/parallel.F90
440	!************************************************************************************
441
442	IF (last) THEN
443	IF (is_sequential) THEN
444	CALL prism_terminate_proto(ierror)
445	IF (ierror .NE. PRISM_Ok) THEN
446	abort_message=' Problem in prism_terminate_proto '
447	CALL abort_gcm(modname,abort_message,1)
448	ENDIF
449	ENDIF
450	ENDIF
451
452
453	END SUBROUTINE intocpl
454
455	#endif
456
457	END MODULE oasis

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

Download in other formats:

Original Format