source: LMDZ4/tags/pre-merge-2009-12/libf/phylmd/oasis.F90 @ 1275

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

Réintegration dans le tronc des modifications issues de la branche LMDZ-dev
comprises entre la révision 1074 et 1145
Validation: une simulation de 1 jour en séquentiel sur PC donne les mêmes
résultats entre la trunk et la dev
LF
  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 16.0 KB
Line 
1!
2MODULE 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! Maximum number of fields exchanged between ocean and atmosphere
26  INTEGER, PARAMETER  :: jpmaxfld=40
27! Number of fields exchanged from atmosphere to ocean via flx.F
28  INTEGER, PARAMETER  :: jpflda2o1=13
29! Number of fields exchanged from atmosphere to ocean via tau.F
30  INTEGER, PARAMETER  :: jpflda2o2=6
31! Number of fields exchanged from ocean to atmosphere
32  INTEGER  :: jpfldo2a
33
34  CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE   :: cl_read
35  !$OMP THREADPRIVATE(cl_read)
36  CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE   :: cl_writ
37  !$OMP THREADPRIVATE(cl_writ)
38
39  INTEGER, DIMENSION(jpmaxfld), SAVE, PRIVATE            :: in_var_id
40  !$OMP THREADPRIVATE(in_var_id)
41  INTEGER, DIMENSION(jpflda2o1+jpflda2o2), SAVE, PRIVATE :: out_var_id
42  !$OMP THREADPRIVATE(out_var_id)
43
44  LOGICAL :: cpl_current
45
46#ifdef CPP_COUPLE
47
48CONTAINS
49
50  SUBROUTINE inicma
51!************************************************************************************
52!**** *INICMA*  - Initialize coupled mode communication for atmosphere
53!                 and exchange some initial information with Oasis
54!
55!     Rewrite to take the PRISM/psmile library into account
56!     LF 09/2003
57!
58    USE IOIPSL
59    USE surface_data, ONLY : version_ocean
60    INCLUDE "dimensions.h"
61
62! Local variables
63!************************************************************************************
64    INTEGER                            :: comp_id
65    INTEGER                            :: ierror, il_commlocal
66    INTEGER                            :: il_part_id
67    INTEGER, DIMENSION(3)              :: ig_paral
68    INTEGER, DIMENSION(2)              :: il_var_nodims
69    INTEGER, DIMENSION(4)              :: il_var_actual_shape
70    INTEGER                            :: il_var_type
71    INTEGER                            :: nuout = 6
72    INTEGER                            :: jf
73    CHARACTER (len = 6)                :: clmodnam
74    CHARACTER (len = 20)               :: modname = 'inicma'
75    CHARACTER (len = 80)               :: abort_message
76    LOGICAL                            :: cpl_current_omp
77
78!*    1. Initializations
79!        ---------------
80!************************************************************************************
81    WRITE(nuout,*) ' '
82    WRITE(nuout,*) ' '
83    WRITE(nuout,*) ' ROUTINE INICMA'
84    WRITE(nuout,*) ' **************'
85    WRITE(nuout,*) ' '
86    WRITE(nuout,*) ' '
87
88!
89! Define the model name
90!
91    clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
92
93!************************************************************************************
94! Define if coupling ocean currents or not
95!************************************************************************************
96!$OMP MASTER
97    cpl_current_omp = .FALSE.
98    CALL getin('cpl_current', cpl_current_omp)
99!$OMP END MASTER
100!$OMP BARRIER
101    cpl_current = cpl_current_omp
102    WRITE(nuout,*) 'Couple ocean currents, cpl_current = ',cpl_current
103
104    IF (cpl_current) THEN
105       jpfldo2a=7
106    ELSE
107       jpfldo2a=4
108    END IF
109!************************************************************************************
110! Here we go: psmile initialisation
111!************************************************************************************
112    IF (is_sequential) THEN
113       CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
114       
115       IF (ierror .NE. PRISM_Ok) THEN
116          abort_message=' Probleme init dans prism_init_comp '
117          CALL abort_gcm(modname,abort_message,1)
118       ELSE
119          WRITE(nuout,*) 'inicma : init psmile ok '
120       ENDIF
121    ENDIF
122
123    CALL prism_get_localcomm_proto (il_commlocal, ierror)
124!************************************************************************************
125! Domain decomposition
126!************************************************************************************
127    ig_paral(1) = 1                            ! apple partition for //
128    ig_paral(2) = (jj_begin-1)*iim+ii_begin-1  ! offset
129    ig_paral(3) = (jj_end*iim+ii_end) - (jj_begin*iim+ii_begin) + 1
130
131    IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
132    WRITE(nuout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
133   
134    ierror=PRISM_Ok
135    CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
136
137    IF (ierror .NE. PRISM_Ok) THEN
138       abort_message=' Probleme dans prism_def_partition '
139       CALL abort_gcm(modname,abort_message,1)
140    ELSE
141       WRITE(nuout,*) 'inicma : decomposition domaine psmile ok '
142    ENDIF
143
144!************************************************************************************
145! Field Declarations
146!************************************************************************************
147!     Define symbolic name for fields exchanged from atmos to coupler,
148!         must be the same as (1) of the field definition in namcouple:
149!
150!   Initialization
151    cl_writ(:)='NOFLDATM'
152
153    cl_writ(1)='COTAUXXU'
154    cl_writ(2)='COTAUYYU'
155    cl_writ(3)='COTAUZZU'
156    cl_writ(4)='COTAUXXV'
157    cl_writ(5)='COTAUYYV'
158    cl_writ(6)='COTAUZZV'
159    cl_writ(7)='COWINDSP'
160    cl_writ(8)='COSHFICE'
161    cl_writ(10)='CONSFICE'
162    cl_writ(12)='CODFLXDT'
163
164    IF (version_ocean=='nemo') THEN
165      cl_writ(9)='COQSRMIX'
166      cl_writ(11)='COQNSMIX'
167      cl_writ(13)='COTOTRAI'
168      cl_writ(14)='COTOTSNO'
169      cl_writ(15)='COTOTEVA'
170      cl_writ(16)='COICEVAP'
171      cl_writ(17)='COCALVIN'
172      cl_writ(18)='COLIQRUN'
173    ELSE IF (version_ocean=='opa8') THEN
174       cl_writ(9)='COSHFOCE'
175       cl_writ(11)='CONSFOCE'
176       cl_writ(13)='COTFSICE'
177       cl_writ(14)='COTFSOCE'
178       cl_writ(15)='COTOLPSU'
179       cl_writ(16)='COTOSPSU'
180       cl_writ(17)='CORUNCOA'
181       cl_writ(18)='CORIVFLU'
182       cl_writ(19)='COCALVIN'
183    ENDIF
184
185!
186!     Define symbolic name for fields exchanged from coupler to atmosphere,
187!         must be the same as (2) of the field definition in namcouple:
188!
189!   Initialization
190    cl_read(:)='NOFLDATM'
191
192    cl_read(1)='SISUTESW'
193    cl_read(2)='SIICECOV'
194    cl_read(3)='SIICEALW'
195    cl_read(4)='SIICTEMW'
196
197    IF (cpl_current) THEN
198       cl_read(5)='CURRENTX'
199       cl_read(6)='CURRENTY'
200       cl_read(7)='CURRENTZ'
201    END IF
202
203    il_var_nodims(1) = 2
204    il_var_nodims(2) = 1
205
206    il_var_actual_shape(1) = 1
207    il_var_actual_shape(2) = iim
208    il_var_actual_shape(3) = 1
209    il_var_actual_shape(4) = jjm+1
210   
211    il_var_type = PRISM_Real
212
213!************************************************************************************
214! Oceanic Fields
215!************************************************************************************
216    DO jf=1, jpfldo2a
217       CALL prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
218            il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
219            ierror)
220       IF (ierror .NE. PRISM_Ok) THEN
221          abort_message=' Probleme init dans prism_def_var_proto '
222          CALL abort_gcm(modname,abort_message,1)
223       ENDIF
224    END DO
225
226!************************************************************************************
227! Atmospheric Fields
228!************************************************************************************
229    DO jf=1, jpflda2o1+jpflda2o2
230       CALL prism_def_var_proto(out_var_id(jf), cl_writ(jf), il_part_id, &
231            il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
232            ierror)
233       IF (ierror .NE. PRISM_Ok) THEN
234          abort_message=' Probleme init dans prism_def_var_proto '
235          CALL abort_gcm(modname,abort_message,1)
236       ENDIF
237    END DO
238
239!************************************************************************************
240! End definition
241!************************************************************************************
242    CALL prism_enddef_proto(ierror)
243    IF (ierror .NE. PRISM_Ok) THEN
244       abort_message=' Probleme init dans prism_ endef_proto'
245       CALL abort_gcm(modname,abort_message,1)
246    ELSE
247       WRITE(nuout,*) 'inicma : endef psmile ok '
248    ENDIF
249   
250  END SUBROUTINE inicma
251
252!
253!************************************************************************************
254!
255
256  SUBROUTINE fromcpl(ktime, tab_get)
257! ======================================================================
258! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
259! and Sea-Ice provided by the coupler. Adaptation to psmile library
260!======================================================================
261!
262    INCLUDE "dimensions.h"
263! Input arguments
264!************************************************************************************
265    INTEGER, INTENT(IN)                               ::  ktime
266
267! Output arguments
268!************************************************************************************
269    REAL, DIMENSION(iim, jj_nb,jpfldo2a), INTENT(OUT) :: tab_get
270
271! Local variables
272!************************************************************************************
273    INTEGER                       :: nuout  = 6             ! listing output unit
274    INTEGER                       :: ierror, i
275    INTEGER                       :: istart,iend
276    CHARACTER (len = 20)          :: modname = 'fromcpl'
277    CHARACTER (len = 80)          :: abort_message
278    REAL, DIMENSION(iim*jj_nb)    :: field
279
280!************************************************************************************
281    WRITE (nuout,*) ' '
282    WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
283    WRITE (nuout,*) ' '
284   
285    istart=ii_begin
286    IF (is_south_pole) THEN
287       iend=(jj_end-jj_begin)*iim+iim
288    ELSE
289       iend=(jj_end-jj_begin)*iim+ii_end
290    ENDIF
291   
292    DO i = 1, jpfldo2a
293       field(:) = -99999.
294       CALL prism_get_proto(in_var_id(i), ktime, field(istart:iend), ierror)
295       tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
296       
297       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
298            ierror.NE.PRISM_FromRest &
299            .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
300            .AND. ierror.NE.PRISM_FromRestOut) THEN
301          WRITE (nuout,*)  cl_read(i), ktime   
302          abort_message=' Probleme dans prism_get_proto '
303          CALL abort_gcm(modname,abort_message,1)
304       ENDIF
305    END DO
306   
307   
308  END SUBROUTINE fromcpl
309
310!
311!************************************************************************************
312!
313
314  SUBROUTINE intocpl(ktime, last, tab_put)
315! ======================================================================
316! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
317! atmospheric coupling fields to the coupler with the psmile library.
318! IF last time step, writes output fields to binary files.
319! ======================================================================
320!
321!
322    INCLUDE "dimensions.h"
323! Input arguments
324!************************************************************************************
325    INTEGER, INTENT(IN)                                          :: ktime
326    LOGICAL, INTENT(IN)                                          :: last
327    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2), INTENT(IN) :: tab_put
328
329! Local variables
330!************************************************************************************
331    LOGICAL                          :: checkout
332    INTEGER                          :: istart,iend
333    INTEGER                          :: wstart,wend
334    INTEGER, PARAMETER               :: nuout = 6
335    INTEGER                          :: ierror, i
336    REAL, DIMENSION(iim*jj_nb)       :: field
337    CHARACTER (len = 20),PARAMETER   :: modname = 'intocpl'
338    CHARACTER (len = 80)             :: abort_message
339
340!************************************************************************************
341    checkout=.FALSE.
342
343    WRITE(nuout,*) ' '
344    WRITE(nuout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
345    WRITE(nuout,*) 'last  ', last
346    WRITE(nuout,*)
347
348
349    istart=ii_begin
350    IF (is_south_pole) THEN
351       iend=(jj_end-jj_begin)*iim+iim
352    ELSE
353       iend=(jj_end-jj_begin)*iim+ii_end
354    ENDIF
355   
356    IF (checkout) THEN   
357       wstart=istart
358       wend=iend
359       IF (is_north_pole) wstart=istart+iim-1
360       IF (is_south_pole) wend=iend-iim+1
361       
362       field = RESHAPE(tab_put(:,:,8),(/iim*jj_nb/))
363       CALL writeField_phy("fsolice",field(wstart:wend),1)
364       field = RESHAPE(tab_put(:,:,9),(/iim*jj_nb/))
365       CALL writeField_phy("fsolwat",field(wstart:wend),1)
366       field = RESHAPE(tab_put(:,:,10),(/iim*jj_nb/))
367       CALL writeField_phy("fnsolice",field(wstart:wend),1)
368       field = RESHAPE(tab_put(:,:,11),(/iim*jj_nb/))
369       CALL writeField_phy("fnsolwat",field(wstart:wend),1)
370       field = RESHAPE(tab_put(:,:,12),(/iim*jj_nb/))
371       CALL writeField_phy("fnsicedt",field(wstart:wend),1)
372       field = RESHAPE(tab_put(:,:,13),(/iim*jj_nb/))
373       CALL writeField_phy("evice",field(wstart:wend),1)
374       field = RESHAPE(tab_put(:,:,14),(/iim*jj_nb/))
375       CALL writeField_phy("evwat",field(wstart:wend),1)
376       field = RESHAPE(tab_put(:,:,15),(/iim*jj_nb/))
377       CALL writeField_phy("lpre",field(wstart:wend),1)
378       field = RESHAPE(tab_put(:,:,16),(/iim*jj_nb/))
379       CALL writeField_phy("spre",field(wstart:wend),1)
380       field = RESHAPE(tab_put(:,:,17),(/iim*jj_nb/))
381       CALL writeField_phy("dirunoff",field(wstart:wend),1)
382       field = RESHAPE(tab_put(:,:,18),(/iim*jj_nb/))
383       CALL writeField_phy("rivrunoff",field(wstart:wend),1)
384       field = RESHAPE(tab_put(:,:,19),(/iim*jj_nb/))
385       CALL writeField_phy("calving",field(wstart:wend),1)
386       field = RESHAPE(tab_put(:,:,1),(/iim*jj_nb/))
387       CALL writeField_phy("tauxx_u",field(wstart:wend),1)
388       field = RESHAPE(tab_put(:,:,2),(/iim*jj_nb/))
389       CALL writeField_phy("tauyy_u",field(wstart:wend),1)
390       field = RESHAPE(tab_put(:,:,3),(/iim*jj_nb/))
391       CALL writeField_phy("tauzz_u",field(wstart:wend),1)
392       field = RESHAPE(tab_put(:,:,4),(/iim*jj_nb/))
393       CALL writeField_phy("tauxx_v",field(wstart:wend),1)
394       field = RESHAPE(tab_put(:,:,5),(/iim*jj_nb/))
395       CALL writeField_phy("tauyy_v",field(wstart:wend),1)
396       field = RESHAPE(tab_put(:,:,6),(/iim*jj_nb/))
397       CALL writeField_phy("tauzz_v",field(wstart:wend),1)
398       field = RESHAPE(tab_put(:,:,7),(/iim*jj_nb/))
399       CALL writeField_phy("windsp",field(wstart:wend),1)
400    ENDIF
401   
402!************************************************************************************
403! PRISM_PUT
404!************************************************************************************
405
406    DO i = 1, jpflda2o1+jpflda2o2
407       field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
408       CALL prism_put_proto(out_var_id(i), ktime, field(istart:iend), ierror)
409       
410       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
411            .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
412            ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
413          WRITE (nuout,*)  cl_writ(i), ktime   
414          abort_message=' Probleme dans prism_put_proto '
415          CALL abort_gcm(modname,abort_message,1)
416       ENDIF
417       
418    END DO
419   
420!************************************************************************************
421! Finalize PSMILE for the case is_sequential, if parallel finalization is done
422! from Finalize_parallel in dyn3dpar/parallel.F90
423!************************************************************************************
424
425    IF (last) THEN
426       IF (is_sequential) THEN
427          CALL prism_terminate_proto(ierror)
428          IF (ierror .NE. PRISM_Ok) THEN
429             abort_message=' Probleme dans prism_terminate_proto '
430             CALL abort_gcm(modname,abort_message,1)
431          ENDIF
432       ENDIF
433    ENDIF
434   
435   
436  END SUBROUTINE intocpl
437
438#endif
439 
440END MODULE oasis
Note: See TracBrowser for help on using the repository browser.