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

Last change on this file since 1073 was 1073, checked in by Laurent Fairhead, 16 years ago

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