source: LMDZ4/branches/LMDZ4-dev/libf/phylmd/oasis.F90 @ 1074

Last change on this file since 1074 was 1067, checked in by Laurent Fairhead, 16 years ago
  • Modifications lie au premier niveau du modele pour la diffusion turbulent

du vent.

  • Preparation pour un couplage des courrant oceaniques.

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