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

Last change on this file since 1106 was 1106, checked in by lguez, 15 years ago

"comconst.h", and "comgeom2.h" are now both fixed and free form.
Removed calls to procedure "flush".
Corrected kinds of constants which appeared as arguments to "min" or
"max" (all arguments are now of the same type and kind).
  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 15.9 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   
283    istart=ii_begin
284    IF (is_south_pole) THEN
285       iend=(jj_end-jj_begin)*iim+iim
286    ELSE
287       iend=(jj_end-jj_begin)*iim+ii_end
288    ENDIF
289   
290    DO i = 1, jpfldo2a
291       field(:) = -99999.
292       CALL prism_get_proto(in_var_id(i), ktime, field(istart:iend), ierror)
293       tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
294       
295       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
296            ierror.NE.PRISM_FromRest &
297            .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
298            .AND. ierror.NE.PRISM_FromRestOut) THEN
299          WRITE (nuout,*)  cl_read(i), ktime   
300          abort_message=' Probleme dans prism_get_proto '
301          CALL abort_gcm(modname,abort_message,1)
302       ENDIF
303    END DO
304   
305   
306  END SUBROUTINE fromcpl
307
308!
309!************************************************************************************
310!
311
312  SUBROUTINE intocpl(ktime, last, tab_put)
313! ======================================================================
314! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
315! atmospheric coupling fields to the coupler with the psmile library.
316! IF last time step, writes output fields to binary files.
317! ======================================================================
318!
319!
320    INCLUDE "dimensions.h"
321! Input arguments
322!************************************************************************************
323    INTEGER, INTENT(IN)                                          :: ktime
324    LOGICAL, INTENT(IN)                                          :: last
325    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2), INTENT(IN) :: tab_put
326
327! Local variables
328!************************************************************************************
329    LOGICAL                          :: checkout
330    INTEGER                          :: istart,iend
331    INTEGER                          :: wstart,wend
332    INTEGER, PARAMETER               :: nuout = 6
333    INTEGER                          :: ierror, i
334    REAL, DIMENSION(iim*jj_nb)       :: field
335    CHARACTER (len = 20),PARAMETER   :: modname = 'intocpl'
336    CHARACTER (len = 80)             :: abort_message
337
338!************************************************************************************
339    checkout=.FALSE.
340
341    WRITE(nuout,*) ' '
342    WRITE(nuout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
343    WRITE(nuout,*) 'last  ', last
344    WRITE(nuout,*)
345
346
347    istart=ii_begin
348    IF (is_south_pole) THEN
349       iend=(jj_end-jj_begin)*iim+iim
350    ELSE
351       iend=(jj_end-jj_begin)*iim+ii_end
352    ENDIF
353   
354    IF (checkout) THEN   
355       wstart=istart
356       wend=iend
357       IF (is_north_pole) wstart=istart+iim-1
358       IF (is_south_pole) wend=iend-iim+1
359       
360       field = RESHAPE(tab_put(:,:,8),(/iim*jj_nb/))
361       CALL writeField_phy("fsolice",field(wstart:wend),1)
362       field = RESHAPE(tab_put(:,:,9),(/iim*jj_nb/))
363       CALL writeField_phy("fsolwat",field(wstart:wend),1)
364       field = RESHAPE(tab_put(:,:,10),(/iim*jj_nb/))
365       CALL writeField_phy("fnsolice",field(wstart:wend),1)
366       field = RESHAPE(tab_put(:,:,11),(/iim*jj_nb/))
367       CALL writeField_phy("fnsolwat",field(wstart:wend),1)
368       field = RESHAPE(tab_put(:,:,12),(/iim*jj_nb/))
369       CALL writeField_phy("fnsicedt",field(wstart:wend),1)
370       field = RESHAPE(tab_put(:,:,13),(/iim*jj_nb/))
371       CALL writeField_phy("evice",field(wstart:wend),1)
372       field = RESHAPE(tab_put(:,:,14),(/iim*jj_nb/))
373       CALL writeField_phy("evwat",field(wstart:wend),1)
374       field = RESHAPE(tab_put(:,:,15),(/iim*jj_nb/))
375       CALL writeField_phy("lpre",field(wstart:wend),1)
376       field = RESHAPE(tab_put(:,:,16),(/iim*jj_nb/))
377       CALL writeField_phy("spre",field(wstart:wend),1)
378       field = RESHAPE(tab_put(:,:,17),(/iim*jj_nb/))
379       CALL writeField_phy("dirunoff",field(wstart:wend),1)
380       field = RESHAPE(tab_put(:,:,18),(/iim*jj_nb/))
381       CALL writeField_phy("rivrunoff",field(wstart:wend),1)
382       field = RESHAPE(tab_put(:,:,19),(/iim*jj_nb/))
383       CALL writeField_phy("calving",field(wstart:wend),1)
384       field = RESHAPE(tab_put(:,:,1),(/iim*jj_nb/))
385       CALL writeField_phy("tauxx_u",field(wstart:wend),1)
386       field = RESHAPE(tab_put(:,:,2),(/iim*jj_nb/))
387       CALL writeField_phy("tauyy_u",field(wstart:wend),1)
388       field = RESHAPE(tab_put(:,:,3),(/iim*jj_nb/))
389       CALL writeField_phy("tauzz_u",field(wstart:wend),1)
390       field = RESHAPE(tab_put(:,:,4),(/iim*jj_nb/))
391       CALL writeField_phy("tauxx_v",field(wstart:wend),1)
392       field = RESHAPE(tab_put(:,:,5),(/iim*jj_nb/))
393       CALL writeField_phy("tauyy_v",field(wstart:wend),1)
394       field = RESHAPE(tab_put(:,:,6),(/iim*jj_nb/))
395       CALL writeField_phy("tauzz_v",field(wstart:wend),1)
396       field = RESHAPE(tab_put(:,:,7),(/iim*jj_nb/))
397       CALL writeField_phy("windsp",field(wstart:wend),1)
398    ENDIF
399   
400!************************************************************************************
401! PRISM_PUT
402!************************************************************************************
403
404    DO i = 1, jpflda2o1+jpflda2o2
405       field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
406       CALL prism_put_proto(out_var_id(i), ktime, field(istart:iend), ierror)
407       
408       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
409            .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
410            ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
411          WRITE (nuout,*)  cl_writ(i), ktime   
412          abort_message=' Probleme dans prism_put_proto '
413          CALL abort_gcm(modname,abort_message,1)
414       ENDIF
415       
416    END DO
417   
418!************************************************************************************
419! Finalize PSMILE for the case is_sequential, if parallel finalization is done
420! from Finalize_parallel in dyn3dpar/parallel.F90
421!************************************************************************************
422
423    IF (last) THEN
424       IF (is_sequential) THEN
425          CALL prism_terminate_proto(ierror)
426          IF (ierror .NE. PRISM_Ok) THEN
427             abort_message=' Probleme dans prism_terminate_proto '
428             CALL abort_gcm(modname,abort_message,1)
429          ENDIF
430       ENDIF
431    ENDIF
432   
433   
434  END SUBROUTINE intocpl
435
436#endif
437 
438END MODULE oasis
Note: See TracBrowser for help on using the repository browser.