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

Last change on this file since 1142 was 1107, 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: 16.2 KB
RevLine 
[782]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
[1067]32  INTEGER  :: jpfldo2a
[782]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
[1067]39  INTEGER, DIMENSION(jpmaxfld), SAVE, PRIVATE            :: in_var_id
[782]40  !$OMP THREADPRIVATE(in_var_id)
41  INTEGER, DIMENSION(jpflda2o1+jpflda2o2), SAVE, PRIVATE :: out_var_id
42  !$OMP THREADPRIVATE(out_var_id)
43
[1067]44  LOGICAL :: cpl_current
[782]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!
[1067]58    USE IOIPSL
[996]59    USE surface_data, ONLY : version_ocean
[793]60    INCLUDE "dimensions.h"
[782]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
[1067]76    LOGICAL                            :: cpl_current_omp
[782]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
[1067]92
[782]93!************************************************************************************
[1067]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!************************************************************************************
[782]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:
[996]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'
[987]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'
[996]171    ELSE IF (version_ocean=='opa8') THEN
172      cl_writ(8) ='COSHFICE'
173      cl_writ(9) ='COSHFOCE'
[987]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
[782]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!
[996]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
[1067]201    cl_read(5)='CURRENTX'
202    cl_read(6)='CURRENTY'
203    cl_read(7)='CURRENTZ'
[996]204
[782]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!
[793]264    INCLUDE "dimensions.h"
[782]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   
287    istart=ii_begin
288    IF (is_south_pole) THEN
289       iend=(jj_end-jj_begin)*iim+iim
290    ELSE
291       iend=(jj_end-jj_begin)*iim+ii_end
292    ENDIF
293   
294    DO i = 1, jpfldo2a
295       field(:) = -99999.
296       CALL prism_get_proto(in_var_id(i), ktime, field(istart:iend), ierror)
297       tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
298       
299       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
300            ierror.NE.PRISM_FromRest &
301            .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
302            .AND. ierror.NE.PRISM_FromRestOut) THEN
303          WRITE (nuout,*)  cl_read(i), ktime   
304          abort_message=' Probleme dans prism_get_proto '
305          CALL abort_gcm(modname,abort_message,1)
306       ENDIF
307    END DO
308   
309   
310  END SUBROUTINE fromcpl
311
312!
313!************************************************************************************
314!
315
316  SUBROUTINE intocpl(ktime, last, tab_put)
317! ======================================================================
318! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
319! atmospheric coupling fields to the coupler with the psmile library.
320! IF last time step, writes output fields to binary files.
321! ======================================================================
322!
323!
[793]324    INCLUDE "dimensions.h"
[782]325! Input arguments
326!************************************************************************************
327    INTEGER, INTENT(IN)                                          :: ktime
328    LOGICAL, INTENT(IN)                                          :: last
329    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2), INTENT(IN) :: tab_put
330
331! Local variables
332!************************************************************************************
[987]333    LOGICAL                          :: checkout
334    INTEGER                          :: istart,iend
335    INTEGER                          :: wstart,wend
336    INTEGER, PARAMETER               :: nuout = 6
337    INTEGER                          :: ierror, i
338    REAL, DIMENSION(iim*jj_nb)       :: field
339    CHARACTER (len = 20),PARAMETER   :: modname = 'intocpl'
340    CHARACTER (len = 80)             :: abort_message
[782]341
342!************************************************************************************
[987]343    checkout=.FALSE.
[782]344
345    WRITE(nuout,*) ' '
346    WRITE(nuout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
347    WRITE(nuout,*) 'last  ', last
348    WRITE(nuout,*)
349
350
351    istart=ii_begin
352    IF (is_south_pole) THEN
353       iend=(jj_end-jj_begin)*iim+iim
354    ELSE
355       iend=(jj_end-jj_begin)*iim+ii_end
356    ENDIF
357   
358    IF (checkout) THEN   
359       wstart=istart
360       wend=iend
361       IF (is_north_pole) wstart=istart+iim-1
362       IF (is_south_pole) wend=iend-iim+1
363       
364       field = RESHAPE(tab_put(:,:,8),(/iim*jj_nb/))
365       CALL writeField_phy("fsolice",field(wstart:wend),1)
366       field = RESHAPE(tab_put(:,:,9),(/iim*jj_nb/))
367       CALL writeField_phy("fsolwat",field(wstart:wend),1)
368       field = RESHAPE(tab_put(:,:,10),(/iim*jj_nb/))
369       CALL writeField_phy("fnsolice",field(wstart:wend),1)
370       field = RESHAPE(tab_put(:,:,11),(/iim*jj_nb/))
371       CALL writeField_phy("fnsolwat",field(wstart:wend),1)
372       field = RESHAPE(tab_put(:,:,12),(/iim*jj_nb/))
373       CALL writeField_phy("fnsicedt",field(wstart:wend),1)
374       field = RESHAPE(tab_put(:,:,13),(/iim*jj_nb/))
375       CALL writeField_phy("evice",field(wstart:wend),1)
376       field = RESHAPE(tab_put(:,:,14),(/iim*jj_nb/))
377       CALL writeField_phy("evwat",field(wstart:wend),1)
378       field = RESHAPE(tab_put(:,:,15),(/iim*jj_nb/))
379       CALL writeField_phy("lpre",field(wstart:wend),1)
380       field = RESHAPE(tab_put(:,:,16),(/iim*jj_nb/))
381       CALL writeField_phy("spre",field(wstart:wend),1)
382       field = RESHAPE(tab_put(:,:,17),(/iim*jj_nb/))
383       CALL writeField_phy("dirunoff",field(wstart:wend),1)
384       field = RESHAPE(tab_put(:,:,18),(/iim*jj_nb/))
385       CALL writeField_phy("rivrunoff",field(wstart:wend),1)
386       field = RESHAPE(tab_put(:,:,19),(/iim*jj_nb/))
387       CALL writeField_phy("calving",field(wstart:wend),1)
388       field = RESHAPE(tab_put(:,:,1),(/iim*jj_nb/))
389       CALL writeField_phy("tauxx_u",field(wstart:wend),1)
390       field = RESHAPE(tab_put(:,:,2),(/iim*jj_nb/))
391       CALL writeField_phy("tauyy_u",field(wstart:wend),1)
392       field = RESHAPE(tab_put(:,:,3),(/iim*jj_nb/))
393       CALL writeField_phy("tauzz_u",field(wstart:wend),1)
394       field = RESHAPE(tab_put(:,:,4),(/iim*jj_nb/))
395       CALL writeField_phy("tauxx_v",field(wstart:wend),1)
396       field = RESHAPE(tab_put(:,:,5),(/iim*jj_nb/))
397       CALL writeField_phy("tauyy_v",field(wstart:wend),1)
398       field = RESHAPE(tab_put(:,:,6),(/iim*jj_nb/))
399       CALL writeField_phy("tauzz_v",field(wstart:wend),1)
400       field = RESHAPE(tab_put(:,:,7),(/iim*jj_nb/))
401       CALL writeField_phy("windsp",field(wstart:wend),1)
402    ENDIF
403   
404!************************************************************************************
405! PRISM_PUT
406!************************************************************************************
407
408    DO i = 1, jpflda2o1+jpflda2o2
409       field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
410       CALL prism_put_proto(out_var_id(i), ktime, field(istart:iend), ierror)
411       
412       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
413            .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
414            ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
415          WRITE (nuout,*)  cl_writ(i), ktime   
416          abort_message=' Probleme dans prism_put_proto '
417          CALL abort_gcm(modname,abort_message,1)
418       ENDIF
419       
420    END DO
421   
422!************************************************************************************
423! Finalize PSMILE for the case is_sequential, if parallel finalization is done
424! from Finalize_parallel in dyn3dpar/parallel.F90
425!************************************************************************************
426
427    IF (last) THEN
428       IF (is_sequential) THEN
429          CALL prism_terminate_proto(ierror)
430          IF (ierror .NE. PRISM_Ok) THEN
431             abort_message=' Probleme dans prism_terminate_proto '
432             CALL abort_gcm(modname,abort_message,1)
433          ENDIF
434       ENDIF
435    ENDIF
436   
437   
438  END SUBROUTINE intocpl
439
440#endif
441 
442END MODULE oasis
Note: See TracBrowser for help on using the repository browser.