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

Last change on this file since 862 was 793, checked in by Laurent Fairhead, 18 years ago

Modifications suite a la transformation des fichiers include pour
qu'ils soient compatibles a la fois au format fixe et au format libre
Un bon nombre de fichiers *.inc du coup disparaissent
LF
  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 14.8 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    INCLUDE "dimensions.h"
60
61! Local variables
62!************************************************************************************
63    INTEGER                            :: comp_id
64    INTEGER                            :: ierror, il_commlocal
65    INTEGER                            :: il_part_id
66    INTEGER, DIMENSION(3)              :: ig_paral
67    INTEGER, DIMENSION(2)              :: il_var_nodims
68    INTEGER, DIMENSION(4)              :: il_var_actual_shape
69    INTEGER                            :: il_var_type
70    INTEGER                            :: nuout = 6
71    INTEGER                            :: jf
72    CHARACTER (len = 6)                :: clmodnam
73    CHARACTER (len = 20)               :: modname = 'inicma'
74    CHARACTER (len = 80)               :: abort_message
75
76!*    1. Initializations
77!        ---------------
78!************************************************************************************
79    WRITE(nuout,*) ' '
80    WRITE(nuout,*) ' '
81    WRITE(nuout,*) ' ROUTINE INICMA'
82    WRITE(nuout,*) ' **************'
83    WRITE(nuout,*) ' '
84    WRITE(nuout,*) ' '
85
86!
87! Define the model name
88!
89    clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
90!
91!************************************************************************************
92! Here we go: psmile initialisation
93!************************************************************************************
94    IF (is_sequential) THEN
95       CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
96       
97       IF (ierror .NE. PRISM_Ok) THEN
98          abort_message=' Probleme init dans prism_init_comp '
99          CALL abort_gcm(modname,abort_message,1)
100       ELSE
101          WRITE(nuout,*) 'inicma : init psmile ok '
102       ENDIF
103    ENDIF
104
105    CALL prism_get_localcomm_proto (il_commlocal, ierror)
106!************************************************************************************
107! Domain decomposition
108!************************************************************************************
109    ig_paral(1) = 1                            ! apple partition for //
110    ig_paral(2) = (jj_begin-1)*iim+ii_begin-1  ! offset
111    ig_paral(3) = (jj_end*iim+ii_end) - (jj_begin*iim+ii_begin) + 1
112
113    IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
114    WRITE(nuout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
115   
116    ierror=PRISM_Ok
117    CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
118
119    IF (ierror .NE. PRISM_Ok) THEN
120       abort_message=' Probleme dans prism_def_partition '
121       CALL abort_gcm(modname,abort_message,1)
122    ELSE
123       WRITE(nuout,*) 'inicma : decomposition domaine psmile ok '
124    ENDIF
125
126!************************************************************************************
127! Field Declarations
128!************************************************************************************
129!     Define symbolic name for fields exchanged from atmos to coupler,
130!         must be the same as (1) of the field  definition in namcouple:
131    cl_writ(1)='COTAUXXU'
132    cl_writ(2)='COTAUYYU'
133    cl_writ(3)='COTAUZZU'
134    cl_writ(4)='COTAUXXV'
135    cl_writ(5)='COTAUYYV'
136    cl_writ(6)='COTAUZZV'
137    cl_writ(7)='COWINDSP'
138    cl_writ(8)='COSHFICE'
139    cl_writ(9)='COSHFOCE'
140    cl_writ(10)='CONSFICE'
141    cl_writ(11)='CONSFOCE'
142    cl_writ(12)='CODFLXDT'
143    cl_writ(13)='COTFSICE'
144    cl_writ(14)='COTFSOCE'
145    cl_writ(15)='COTOLPSU'
146    cl_writ(16)='COTOSPSU'
147    cl_writ(17)='CORUNCOA'
148    cl_writ(18)='CORIVFLU'
149    cl_writ(19)='COCALVIN'
150!
151!     Define symbolic name for fields exchanged from coupler to atmosphere,
152!         must be the same as (2) of the field  definition in namcouple:
153!
154    cl_read(1)='SISUTESW'
155    cl_read(2)='SIICECOV'
156    cl_read(3)='SIICEALW'
157    cl_read(4)='SIICTEMW'
158   
159    il_var_nodims(1) = 2
160    il_var_nodims(2) = 1
161
162    il_var_actual_shape(1) = 1
163    il_var_actual_shape(2) = iim
164    il_var_actual_shape(3) = 1
165    il_var_actual_shape(4) = jjm+1
166   
167    il_var_type = PRISM_Real
168
169!************************************************************************************
170! Oceanic Fields
171!************************************************************************************
172    DO jf=1, jpfldo2a
173       CALL prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
174            il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
175            ierror)
176       IF (ierror .NE. PRISM_Ok) THEN
177          abort_message=' Probleme init dans prism_def_var_proto '
178          CALL abort_gcm(modname,abort_message,1)
179       ENDIF
180    END DO
181
182!************************************************************************************
183! Atmospheric Fields
184!************************************************************************************
185    DO jf=1, jpflda2o1+jpflda2o2
186       CALL prism_def_var_proto(out_var_id(jf), cl_writ(jf), il_part_id, &
187            il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
188            ierror)
189       IF (ierror .NE. PRISM_Ok) THEN
190          abort_message=' Probleme init dans prism_def_var_proto '
191          CALL abort_gcm(modname,abort_message,1)
192       ENDIF
193    END DO
194
195!************************************************************************************
196! End definition
197!************************************************************************************
198    CALL prism_enddef_proto(ierror)
199    IF (ierror .NE. PRISM_Ok) THEN
200       abort_message=' Probleme init dans prism_ endef_proto'
201       CALL abort_gcm(modname,abort_message,1)
202    ELSE
203       WRITE(nuout,*) 'inicma : endef psmile ok '
204    ENDIF
205   
206  END SUBROUTINE inicma
207
208!
209!************************************************************************************
210!
211
212  SUBROUTINE fromcpl(ktime, tab_get)
213! ======================================================================
214! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
215! and Sea-Ice provided by the coupler. Adaptation to psmile library
216!======================================================================
217!
218    INCLUDE "dimensions.h"
219! Input arguments
220!************************************************************************************
221    INTEGER, INTENT(IN)                               ::  ktime
222
223! Output arguments
224!************************************************************************************
225    REAL, DIMENSION(iim, jj_nb,jpfldo2a), INTENT(OUT) :: tab_get
226
227! Local variables
228!************************************************************************************
229    INTEGER                       :: nuout  = 6             ! listing output unit
230    INTEGER                       :: ierror, i
231    INTEGER                       :: istart,iend
232    CHARACTER (len = 20)          :: modname = 'fromcpl'
233    CHARACTER (len = 80)          :: abort_message
234    REAL, DIMENSION(iim*jj_nb)    :: field
235
236!************************************************************************************
237    WRITE (nuout,*) ' '
238    WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
239    WRITE (nuout,*) ' '
240    CALL flush (nuout)
241   
242    istart=ii_begin
243    IF (is_south_pole) THEN
244       iend=(jj_end-jj_begin)*iim+iim
245    ELSE
246       iend=(jj_end-jj_begin)*iim+ii_end
247    ENDIF
248   
249    DO i = 1, jpfldo2a
250       field(:) = -99999.
251       CALL prism_get_proto(in_var_id(i), ktime, field(istart:iend), ierror)
252       tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
253       
254       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
255            ierror.NE.PRISM_FromRest &
256            .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
257            .AND. ierror.NE.PRISM_FromRestOut) THEN
258          WRITE (nuout,*)  cl_read(i), ktime   
259          abort_message=' Probleme dans prism_get_proto '
260          CALL abort_gcm(modname,abort_message,1)
261       ENDIF
262    END DO
263   
264   
265  END SUBROUTINE fromcpl
266
267!
268!************************************************************************************
269!
270
271  SUBROUTINE intocpl(ktime, last, tab_put)
272! ======================================================================
273! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
274! atmospheric coupling fields to the coupler with the psmile library.
275! IF last time step, writes output fields to binary files.
276! ======================================================================
277!
278!
279    INCLUDE "dimensions.h"
280! Input arguments
281!************************************************************************************
282    INTEGER, INTENT(IN)                                          :: ktime
283    LOGICAL, INTENT(IN)                                          :: last
284    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2), INTENT(IN) :: tab_put
285
286! Local variables
287!************************************************************************************
288    LOGICAL                     :: checkout=.FALSE.
289    INTEGER                     :: istart,iend
290    INTEGER                     :: wstart,wend
291    INTEGER, PARAMETER          :: nuout = 6
292    INTEGER                     :: ierror, i
293    REAL, DIMENSION(iim*jj_nb)  :: field
294    CHARACTER (len = 20),SAVE   :: modname = 'intocpl'
295    CHARACTER (len = 80)        :: abort_message
296
297!************************************************************************************
298
299    WRITE(nuout,*) ' '
300    WRITE(nuout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
301    WRITE(nuout,*) 'last  ', last
302    WRITE(nuout,*)
303
304
305    istart=ii_begin
306    IF (is_south_pole) THEN
307       iend=(jj_end-jj_begin)*iim+iim
308    ELSE
309       iend=(jj_end-jj_begin)*iim+ii_end
310    ENDIF
311   
312    IF (checkout) THEN   
313       wstart=istart
314       wend=iend
315       IF (is_north_pole) wstart=istart+iim-1
316       IF (is_south_pole) wend=iend-iim+1
317       
318       field = RESHAPE(tab_put(:,:,8),(/iim*jj_nb/))
319       CALL writeField_phy("fsolice",field(wstart:wend),1)
320       field = RESHAPE(tab_put(:,:,9),(/iim*jj_nb/))
321       CALL writeField_phy("fsolwat",field(wstart:wend),1)
322       field = RESHAPE(tab_put(:,:,10),(/iim*jj_nb/))
323       CALL writeField_phy("fnsolice",field(wstart:wend),1)
324       field = RESHAPE(tab_put(:,:,11),(/iim*jj_nb/))
325       CALL writeField_phy("fnsolwat",field(wstart:wend),1)
326       field = RESHAPE(tab_put(:,:,12),(/iim*jj_nb/))
327       CALL writeField_phy("fnsicedt",field(wstart:wend),1)
328       field = RESHAPE(tab_put(:,:,13),(/iim*jj_nb/))
329       CALL writeField_phy("evice",field(wstart:wend),1)
330       field = RESHAPE(tab_put(:,:,14),(/iim*jj_nb/))
331       CALL writeField_phy("evwat",field(wstart:wend),1)
332       field = RESHAPE(tab_put(:,:,15),(/iim*jj_nb/))
333       CALL writeField_phy("lpre",field(wstart:wend),1)
334       field = RESHAPE(tab_put(:,:,16),(/iim*jj_nb/))
335       CALL writeField_phy("spre",field(wstart:wend),1)
336       field = RESHAPE(tab_put(:,:,17),(/iim*jj_nb/))
337       CALL writeField_phy("dirunoff",field(wstart:wend),1)
338       field = RESHAPE(tab_put(:,:,18),(/iim*jj_nb/))
339       CALL writeField_phy("rivrunoff",field(wstart:wend),1)
340       field = RESHAPE(tab_put(:,:,19),(/iim*jj_nb/))
341       CALL writeField_phy("calving",field(wstart:wend),1)
342       field = RESHAPE(tab_put(:,:,1),(/iim*jj_nb/))
343       CALL writeField_phy("tauxx_u",field(wstart:wend),1)
344       field = RESHAPE(tab_put(:,:,2),(/iim*jj_nb/))
345       CALL writeField_phy("tauyy_u",field(wstart:wend),1)
346       field = RESHAPE(tab_put(:,:,3),(/iim*jj_nb/))
347       CALL writeField_phy("tauzz_u",field(wstart:wend),1)
348       field = RESHAPE(tab_put(:,:,4),(/iim*jj_nb/))
349       CALL writeField_phy("tauxx_v",field(wstart:wend),1)
350       field = RESHAPE(tab_put(:,:,5),(/iim*jj_nb/))
351       CALL writeField_phy("tauyy_v",field(wstart:wend),1)
352       field = RESHAPE(tab_put(:,:,6),(/iim*jj_nb/))
353       CALL writeField_phy("tauzz_v",field(wstart:wend),1)
354       field = RESHAPE(tab_put(:,:,7),(/iim*jj_nb/))
355       CALL writeField_phy("windsp",field(wstart:wend),1)
356    ENDIF
357   
358!************************************************************************************
359! PRISM_PUT
360!************************************************************************************
361
362    DO i = 1, jpflda2o1+jpflda2o2
363       field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
364       CALL prism_put_proto(out_var_id(i), ktime, field(istart:iend), ierror)
365       
366       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
367            .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
368            ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
369          WRITE (nuout,*)  cl_writ(i), ktime   
370          abort_message=' Probleme dans prism_put_proto '
371          CALL abort_gcm(modname,abort_message,1)
372       ENDIF
373       
374    END DO
375   
376!************************************************************************************
377! Finalize PSMILE for the case is_sequential, if parallel finalization is done
378! from Finalize_parallel in dyn3dpar/parallel.F90
379!************************************************************************************
380
381    IF (last) THEN
382       IF (is_sequential) THEN
383          CALL prism_terminate_proto(ierror)
384          IF (ierror .NE. PRISM_Ok) THEN
385             abort_message=' Probleme dans prism_terminate_proto '
386             CALL abort_gcm(modname,abort_message,1)
387          ENDIF
388       ENDIF
389    ENDIF
390   
391   
392  END SUBROUTINE intocpl
393
394#endif
395 
396END MODULE oasis
Note: See TracBrowser for help on using the repository browser.