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

Last change on this file since 1079 was 1079, checked in by jghattas, 15 years ago

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