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

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

Modification des champs de couplage pour NEMO.

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.2 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, 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!
57    USE surface_data, ONLY : version_ocean
58    INCLUDE "dimensions.h"
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,
129!         must be the same as (1) of the field definition in namcouple:
130!
131!   Initialization
132    cl_writ(:)='NOFLDATM'
133
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'
141    cl_writ(8)='COSHFICE'
142    cl_writ(9)='COSHFOCE'
143    cl_writ(10)='CONSFICE'
144    cl_writ(11)='CONSFOCE'
145    cl_writ(12)='CODFLXDT'
146
147    IF (version_ocean=='nemo') THEN
148      cl_writ(13)='COEMPSIC'
149      cl_writ(14)='CONESOPR'
150      cl_writ(15)='COEMPOCE'
151      cl_writ(16)='COICEVAP'
152      cl_writ(17)='COCALVIN'
153      cl_writ(18)='COLIQRUN'
154    ELSE IF (version_ocean=='opa8') THEN
155       cl_writ(13)='COTFSICE'
156       cl_writ(14)='COTFSOCE'
157       cl_writ(15)='COTOLPSU'
158       cl_writ(16)='COTOSPSU'
159       cl_writ(17)='CORUNCOA'
160       cl_writ(18)='CORIVFLU'
161       cl_writ(19)='COCALVIN'
162    ENDIF
163!
164!     Define symbolic name for fields exchanged from coupler to atmosphere,
165!         must be the same as (2) of the field definition in namcouple:
166!
167!   Initialization
168    cl_read(:)='NOFLDATM'
169
170    cl_read(1)='SISUTESW'
171    cl_read(2)='SIICECOV'
172    cl_read(3)='SIICEALW'
173    cl_read(4)='SIICTEMW'
174   
175    il_var_nodims(1) = 2
176    il_var_nodims(2) = 1
177
178    il_var_actual_shape(1) = 1
179    il_var_actual_shape(2) = iim
180    il_var_actual_shape(3) = 1
181    il_var_actual_shape(4) = jjm+1
182   
183    il_var_type = PRISM_Real
184
185!************************************************************************************
186! Oceanic Fields
187!************************************************************************************
188    DO jf=1, jpfldo2a
189       CALL prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
190            il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
191            ierror)
192       IF (ierror .NE. PRISM_Ok) THEN
193          abort_message=' Probleme init dans prism_def_var_proto '
194          CALL abort_gcm(modname,abort_message,1)
195       ENDIF
196    END DO
197
198!************************************************************************************
199! Atmospheric Fields
200!************************************************************************************
201    DO jf=1, jpflda2o1+jpflda2o2
202       CALL prism_def_var_proto(out_var_id(jf), cl_writ(jf), il_part_id, &
203            il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
204            ierror)
205       IF (ierror .NE. PRISM_Ok) THEN
206          abort_message=' Probleme init dans prism_def_var_proto '
207          CALL abort_gcm(modname,abort_message,1)
208       ENDIF
209    END DO
210
211!************************************************************************************
212! End definition
213!************************************************************************************
214    CALL prism_enddef_proto(ierror)
215    IF (ierror .NE. PRISM_Ok) THEN
216       abort_message=' Probleme init dans prism_ endef_proto'
217       CALL abort_gcm(modname,abort_message,1)
218    ELSE
219       WRITE(nuout,*) 'inicma : endef psmile ok '
220    ENDIF
221   
222  END SUBROUTINE inicma
223
224!
225!************************************************************************************
226!
227
228  SUBROUTINE fromcpl(ktime, tab_get)
229! ======================================================================
230! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
231! and Sea-Ice provided by the coupler. Adaptation to psmile library
232!======================================================================
233!
234    INCLUDE "dimensions.h"
235! Input arguments
236!************************************************************************************
237    INTEGER, INTENT(IN)                               ::  ktime
238
239! Output arguments
240!************************************************************************************
241    REAL, DIMENSION(iim, jj_nb,jpfldo2a), INTENT(OUT) :: tab_get
242
243! Local variables
244!************************************************************************************
245    INTEGER                       :: nuout  = 6             ! listing output unit
246    INTEGER                       :: ierror, i
247    INTEGER                       :: istart,iend
248    CHARACTER (len = 20)          :: modname = 'fromcpl'
249    CHARACTER (len = 80)          :: abort_message
250    REAL, DIMENSION(iim*jj_nb)    :: field
251
252!************************************************************************************
253    WRITE (nuout,*) ' '
254    WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
255    WRITE (nuout,*) ' '
256    CALL flush (nuout)
257   
258    istart=ii_begin
259    IF (is_south_pole) THEN
260       iend=(jj_end-jj_begin)*iim+iim
261    ELSE
262       iend=(jj_end-jj_begin)*iim+ii_end
263    ENDIF
264   
265    DO i = 1, jpfldo2a
266       field(:) = -99999.
267       CALL prism_get_proto(in_var_id(i), ktime, field(istart:iend), ierror)
268       tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
269       
270       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
271            ierror.NE.PRISM_FromRest &
272            .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
273            .AND. ierror.NE.PRISM_FromRestOut) THEN
274          WRITE (nuout,*)  cl_read(i), ktime   
275          abort_message=' Probleme dans prism_get_proto '
276          CALL abort_gcm(modname,abort_message,1)
277       ENDIF
278    END DO
279   
280   
281  END SUBROUTINE fromcpl
282
283!
284!************************************************************************************
285!
286
287  SUBROUTINE intocpl(ktime, last, tab_put)
288! ======================================================================
289! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
290! atmospheric coupling fields to the coupler with the psmile library.
291! IF last time step, writes output fields to binary files.
292! ======================================================================
293!
294!
295    INCLUDE "dimensions.h"
296! Input arguments
297!************************************************************************************
298    INTEGER, INTENT(IN)                                          :: ktime
299    LOGICAL, INTENT(IN)                                          :: last
300    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2), INTENT(IN) :: tab_put
301
302! Local variables
303!************************************************************************************
304    LOGICAL                     :: checkout=.FALSE.
305    INTEGER                     :: istart,iend
306    INTEGER                     :: wstart,wend
307    INTEGER, PARAMETER          :: nuout = 6
308    INTEGER                     :: ierror, i
309    REAL, DIMENSION(iim*jj_nb)  :: field
310    CHARACTER (len = 20),SAVE   :: modname = 'intocpl'
311    CHARACTER (len = 80)        :: abort_message
312
313!************************************************************************************
314
315    WRITE(nuout,*) ' '
316    WRITE(nuout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
317    WRITE(nuout,*) 'last  ', last
318    WRITE(nuout,*)
319
320
321    istart=ii_begin
322    IF (is_south_pole) THEN
323       iend=(jj_end-jj_begin)*iim+iim
324    ELSE
325       iend=(jj_end-jj_begin)*iim+ii_end
326    ENDIF
327   
328    IF (checkout) THEN   
329       wstart=istart
330       wend=iend
331       IF (is_north_pole) wstart=istart+iim-1
332       IF (is_south_pole) wend=iend-iim+1
333       
334       field = RESHAPE(tab_put(:,:,8),(/iim*jj_nb/))
335       CALL writeField_phy("fsolice",field(wstart:wend),1)
336       field = RESHAPE(tab_put(:,:,9),(/iim*jj_nb/))
337       CALL writeField_phy("fsolwat",field(wstart:wend),1)
338       field = RESHAPE(tab_put(:,:,10),(/iim*jj_nb/))
339       CALL writeField_phy("fnsolice",field(wstart:wend),1)
340       field = RESHAPE(tab_put(:,:,11),(/iim*jj_nb/))
341       CALL writeField_phy("fnsolwat",field(wstart:wend),1)
342       field = RESHAPE(tab_put(:,:,12),(/iim*jj_nb/))
343       CALL writeField_phy("fnsicedt",field(wstart:wend),1)
344       field = RESHAPE(tab_put(:,:,13),(/iim*jj_nb/))
345       CALL writeField_phy("evice",field(wstart:wend),1)
346       field = RESHAPE(tab_put(:,:,14),(/iim*jj_nb/))
347       CALL writeField_phy("evwat",field(wstart:wend),1)
348       field = RESHAPE(tab_put(:,:,15),(/iim*jj_nb/))
349       CALL writeField_phy("lpre",field(wstart:wend),1)
350       field = RESHAPE(tab_put(:,:,16),(/iim*jj_nb/))
351       CALL writeField_phy("spre",field(wstart:wend),1)
352       field = RESHAPE(tab_put(:,:,17),(/iim*jj_nb/))
353       CALL writeField_phy("dirunoff",field(wstart:wend),1)
354       field = RESHAPE(tab_put(:,:,18),(/iim*jj_nb/))
355       CALL writeField_phy("rivrunoff",field(wstart:wend),1)
356       field = RESHAPE(tab_put(:,:,19),(/iim*jj_nb/))
357       CALL writeField_phy("calving",field(wstart:wend),1)
358       field = RESHAPE(tab_put(:,:,1),(/iim*jj_nb/))
359       CALL writeField_phy("tauxx_u",field(wstart:wend),1)
360       field = RESHAPE(tab_put(:,:,2),(/iim*jj_nb/))
361       CALL writeField_phy("tauyy_u",field(wstart:wend),1)
362       field = RESHAPE(tab_put(:,:,3),(/iim*jj_nb/))
363       CALL writeField_phy("tauzz_u",field(wstart:wend),1)
364       field = RESHAPE(tab_put(:,:,4),(/iim*jj_nb/))
365       CALL writeField_phy("tauxx_v",field(wstart:wend),1)
366       field = RESHAPE(tab_put(:,:,5),(/iim*jj_nb/))
367       CALL writeField_phy("tauyy_v",field(wstart:wend),1)
368       field = RESHAPE(tab_put(:,:,6),(/iim*jj_nb/))
369       CALL writeField_phy("tauzz_v",field(wstart:wend),1)
370       field = RESHAPE(tab_put(:,:,7),(/iim*jj_nb/))
371       CALL writeField_phy("windsp",field(wstart:wend),1)
372    ENDIF
373   
374!************************************************************************************
375! PRISM_PUT
376!************************************************************************************
377
378    DO i = 1, jpflda2o1+jpflda2o2
379       field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
380       CALL prism_put_proto(out_var_id(i), ktime, field(istart:iend), ierror)
381       
382       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
383            .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
384            ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
385          WRITE (nuout,*)  cl_writ(i), ktime   
386          abort_message=' Probleme dans prism_put_proto '
387          CALL abort_gcm(modname,abort_message,1)
388       ENDIF
389       
390    END DO
391   
392!************************************************************************************
393! Finalize PSMILE for the case is_sequential, if parallel finalization is done
394! from Finalize_parallel in dyn3dpar/parallel.F90
395!************************************************************************************
396
397    IF (last) THEN
398       IF (is_sequential) THEN
399          CALL prism_terminate_proto(ierror)
400          IF (ierror .NE. PRISM_Ok) THEN
401             abort_message=' Probleme dans prism_terminate_proto '
402             CALL abort_gcm(modname,abort_message,1)
403          ENDIF
404       ENDIF
405    ENDIF
406   
407   
408  END SUBROUTINE intocpl
409
410#endif
411 
412END MODULE oasis
Note: See TracBrowser for help on using the repository browser.