source: LMDZ4/trunk/libf/phylmd/oasis.F90 @ 996

Last change on this file since 996 was 996, checked in by lsce, 16 years ago
  • Modifications liées au calcul des nouveau sous-fractions
  • Nettoyage de ocean slab : il reste uniquement la version avec glace de mer forcé
  • Nouveaux variables pour distiguer la version et type d'ocean : type_ocean=force/slab/couple, version_ocean=opa8/nemo pour couplé ou version_ocean=sicOBS pour slab

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