source: LMDZ4/trunk/libf/phylmd/oasis.F90 @ 1040

Last change on this file since 1040 was 1001, checked in by Laurent Fairhead, 16 years ago
  • Modifs sur le parallelisme: masquage dans la physique
  • Inclusion strato
  • mise en coherence etat0
  • le mode offline fonctionne maintenant en parallele,
  • les fichiers de la dynamiques sont correctement sortis et peuvent etre reconstruit avec rebuild
  • la version parallele de la dynamique peut s'executer sans MPI (sur 1 proc)
  • L'OPENMP fonctionne maintenant sans la parallelisation MPI.

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