source: LMDZ4/branches/LMDZ4_V3_patches/libf/phylmd/oasis.F90 @ 5086

Last change on this file since 5086 was 1124, checked in by jghattas, 16 years ago

Modification pour couplage conservatif avec NEMO : passage des champs totaux et champs sur la glace au lieu de passage des champs sur l'ocean et champs sur la glace.

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