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

Last change on this file since 1211 was 1152, checked in by jghattas, 16 years ago
  • Amelioration dans l'interface de couplage pour faciliter des champs de couplages optionels.
  • Ajout de couplage de flux co2 : uniquement dans l'interface de couplage, pas encore de transport.
  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 18.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
[1152]24 
25  ! Id for fields sent to ocean
26  INTEGER, PARAMETER :: ids_tauxxu = 1
27  INTEGER, PARAMETER :: ids_tauyyu = 2
28  INTEGER, PARAMETER :: ids_tauzzu = 3
29  INTEGER, PARAMETER :: ids_tauxxv = 4
30  INTEGER, PARAMETER :: ids_tauyyv = 5
31  INTEGER, PARAMETER :: ids_tauzzv = 6
32  INTEGER, PARAMETER :: ids_windsp = 7
33  INTEGER, PARAMETER :: ids_shfice = 8
34  INTEGER, PARAMETER :: ids_shfoce = 9
35  INTEGER, PARAMETER :: ids_shftot = 10
36  INTEGER, PARAMETER :: ids_nsfice = 11
37  INTEGER, PARAMETER :: ids_nsfoce = 12
38  INTEGER, PARAMETER :: ids_nsftot = 13
39  INTEGER, PARAMETER :: ids_dflxdt = 14
40  INTEGER, PARAMETER :: ids_totrai = 15
41  INTEGER, PARAMETER :: ids_totsno = 16
42  INTEGER, PARAMETER :: ids_toteva = 17
43  INTEGER, PARAMETER :: ids_icevap = 18
44  INTEGER, PARAMETER :: ids_ocevap = 19
45  INTEGER, PARAMETER :: ids_calvin = 20
46  INTEGER, PARAMETER :: ids_liqrun = 21
47  INTEGER, PARAMETER :: ids_runcoa = 22
48  INTEGER, PARAMETER :: ids_rivflu = 23
49  INTEGER, PARAMETER :: ids_atmco2 = 24
50  INTEGER, PARAMETER :: maxsend    = 24  ! Maximum number of fields to send
51 
52  ! Id for fields received from ocean
53  INTEGER, PARAMETER :: idr_sisutw = 1
54  INTEGER, PARAMETER :: idr_icecov = 2
55  INTEGER, PARAMETER :: idr_icealw = 3
56  INTEGER, PARAMETER :: idr_icetem = 4
57  INTEGER, PARAMETER :: idr_curenx = 5
58  INTEGER, PARAMETER :: idr_cureny = 6
59  INTEGER, PARAMETER :: idr_curenz = 7
60  INTEGER, PARAMETER :: idr_oceco2 = 8
61  INTEGER, PARAMETER :: maxrecv    = 8  ! Maximum number of fields to receive
62 
[782]63
[1152]64  TYPE, PUBLIC ::   FLD_CPL            ! Type for coupling field information
65     CHARACTER(len = 8) ::   name      ! Name of the coupling field   
66     LOGICAL            ::   action    ! To be exchanged or not
67     INTEGER            ::   nid       ! Id of the field
68  END TYPE FLD_CPL
[782]69
[1152]70  TYPE(FLD_CPL), DIMENSION(maxsend), PUBLIC :: infosend   ! Information for sending coupling fields
71  TYPE(FLD_CPL), DIMENSION(maxrecv), PUBLIC :: inforecv   ! Information for receiving coupling fields
72 
[1067]73  LOGICAL :: cpl_current
[1152]74  LOGICAL :: cpl_carbon_cycle
[782]75
76#ifdef CPP_COUPLE
77
78CONTAINS
79
80  SUBROUTINE inicma
81!************************************************************************************
82!**** *INICMA*  - Initialize coupled mode communication for atmosphere
83!                 and exchange some initial information with Oasis
84!
85!     Rewrite to take the PRISM/psmile library into account
86!     LF 09/2003
87!
[1067]88    USE IOIPSL
[996]89    USE surface_data, ONLY : version_ocean
[793]90    INCLUDE "dimensions.h"
[1152]91    INCLUDE "iniprint.h"
[782]92
93! Local variables
94!************************************************************************************
95    INTEGER                            :: comp_id
96    INTEGER                            :: ierror, il_commlocal
97    INTEGER                            :: il_part_id
98    INTEGER, DIMENSION(3)              :: ig_paral
99    INTEGER, DIMENSION(2)              :: il_var_nodims
100    INTEGER, DIMENSION(4)              :: il_var_actual_shape
101    INTEGER                            :: il_var_type
102    INTEGER                            :: jf
103    CHARACTER (len = 6)                :: clmodnam
104    CHARACTER (len = 20)               :: modname = 'inicma'
105    CHARACTER (len = 80)               :: abort_message
[1067]106    LOGICAL                            :: cpl_current_omp
[1152]107    LOGICAL                            :: cpl_carbon_cycle_omp
[782]108
109!*    1. Initializations
110!        ---------------
111!************************************************************************************
[1152]112    WRITE(lunout,*) ' '
113    WRITE(lunout,*) ' '
114    WRITE(lunout,*) ' ROUTINE INICMA'
115    WRITE(lunout,*) ' **************'
116    WRITE(lunout,*) ' '
117    WRITE(lunout,*) ' '
[782]118
119!
120! Define the model name
121!
122    clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
[1067]123
[1152]124
[782]125!************************************************************************************
[1067]126! Define if coupling ocean currents or not
127!************************************************************************************
128!$OMP MASTER
129    cpl_current_omp = .FALSE.
130    CALL getin('cpl_current', cpl_current_omp)
131!$OMP END MASTER
132!$OMP BARRIER
133    cpl_current = cpl_current_omp
[1152]134    WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current
[1067]135
136!************************************************************************************
[1152]137! Define if coupling carbon cycle or not
138!************************************************************************************
139!$OMP MASTER
140    cpl_carbon_cycle_omp = .FALSE.
141    CALL getin('cpl_carbon_cycle', cpl_carbon_cycle_omp)
142!$OMP END MASTER
143!$OMP BARRIER
144    cpl_carbon_cycle=cpl_carbon_cycle_omp
145    WRITE(lunout,*) 'Couple carbon cycle , cpl_carbon_cycle = ',cpl_carbon_cycle
146
147!************************************************************************************
148! Define coupling variables
149!************************************************************************************
150
151! Atmospheric variables to send
152
153    infosend(:)%action = .FALSE.
154
155    infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU'
156    infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU'
157    infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU'
158    infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV'
159    infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV'
160    infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV'
161    infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP'
162    infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE'
163    infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE'
164    infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT'
165    infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN'
166   
167   
168    IF (version_ocean=='nemo') THEN
169        infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX'
170        infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX'
171        infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI'
172        infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO'
173        infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA'
174        infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP'
175        infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN'
176        IF (cpl_carbon_cycle) THEN
177            infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2'
178        ENDIF
179       
180    ELSE IF (version_ocean=='opa8') THEN
181        infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE'
182        infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE'
183        infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE'
184        infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE'
185        infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU'
186        infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU'
187        infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA'
188        infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU'
189   ENDIF
190       
191! Oceanic variables to receive
192
193   inforecv(:)%action = .FALSE.
194
195   inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW'
196   inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV'
197   inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW'
198   inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW'
199   
200   IF (cpl_current ) THEN
201       inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX'
202       inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY'
203       inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ'
204   ENDIF
205
206   IF (cpl_carbon_cycle ) THEN
207       inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX'
208   ENDIF
209
210!************************************************************************************
[782]211! Here we go: psmile initialisation
212!************************************************************************************
213    IF (is_sequential) THEN
214       CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
215       
216       IF (ierror .NE. PRISM_Ok) THEN
217          abort_message=' Probleme init dans prism_init_comp '
218          CALL abort_gcm(modname,abort_message,1)
219       ELSE
[1152]220          WRITE(lunout,*) 'inicma : init psmile ok '
[782]221       ENDIF
222    ENDIF
223
224    CALL prism_get_localcomm_proto (il_commlocal, ierror)
225!************************************************************************************
226! Domain decomposition
227!************************************************************************************
228    ig_paral(1) = 1                            ! apple partition for //
229    ig_paral(2) = (jj_begin-1)*iim+ii_begin-1  ! offset
230    ig_paral(3) = (jj_end*iim+ii_end) - (jj_begin*iim+ii_begin) + 1
231
232    IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
[1152]233    WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
[782]234   
235    ierror=PRISM_Ok
236    CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
237
238    IF (ierror .NE. PRISM_Ok) THEN
239       abort_message=' Probleme dans prism_def_partition '
240       CALL abort_gcm(modname,abort_message,1)
241    ELSE
[1152]242       WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
[782]243    ENDIF
244
245    il_var_nodims(1) = 2
246    il_var_nodims(2) = 1
247
248    il_var_actual_shape(1) = 1
249    il_var_actual_shape(2) = iim
250    il_var_actual_shape(3) = 1
251    il_var_actual_shape(4) = jjm+1
252   
253    il_var_type = PRISM_Real
254
255!************************************************************************************
[1152]256! Oceanic Fields to receive
257! Loop over all possible variables
[782]258!************************************************************************************
[1152]259    DO jf=1, maxrecv
260       IF (inforecv(jf)%action) THEN
261          CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, &
262               il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
263               ierror)
264          IF (ierror .NE. PRISM_Ok) THEN
265             WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
266                  inforecv(jf)%name
267             abort_message=' Problem in call to prism_def_var_proto for fields to receive'
268             CALL abort_gcm(modname,abort_message,1)
269          ENDIF
[782]270       ENDIF
271    END DO
[1152]272   
[782]273!************************************************************************************
[1152]274! Atmospheric Fields to send
275! Loop over all possible variables
[782]276!************************************************************************************
[1152]277    DO jf=1,maxsend
278       IF (infosend(jf)%action) THEN
279          CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
280               il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
281               ierror)
282          IF (ierror .NE. PRISM_Ok) THEN
283             WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
284                  infosend(jf)%name
285             abort_message=' Problem in call to prism_def_var_proto for fields to send'
286             CALL abort_gcm(modname,abort_message,1)
287          ENDIF
[782]288       ENDIF
289    END DO
[1152]290   
[782]291!************************************************************************************
292! End definition
293!************************************************************************************
294    CALL prism_enddef_proto(ierror)
295    IF (ierror .NE. PRISM_Ok) THEN
[1152]296       abort_message=' Problem in call to prism_endef_proto'
[782]297       CALL abort_gcm(modname,abort_message,1)
298    ELSE
[1152]299       WRITE(lunout,*) 'inicma : endef psmile ok '
[782]300    ENDIF
301   
302  END SUBROUTINE inicma
303
304!
305!************************************************************************************
306!
307
308  SUBROUTINE fromcpl(ktime, tab_get)
309! ======================================================================
310! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
311! and Sea-Ice provided by the coupler. Adaptation to psmile library
312!======================================================================
313!
[793]314    INCLUDE "dimensions.h"
[1152]315    INCLUDE "iniprint.h"
[782]316! Input arguments
317!************************************************************************************
318    INTEGER, INTENT(IN)                               ::  ktime
319
320! Output arguments
321!************************************************************************************
[1152]322    REAL, DIMENSION(iim, jj_nb,maxrecv), INTENT(OUT) :: tab_get
[782]323
324! Local variables
325!************************************************************************************
326    INTEGER                       :: ierror, i
327    INTEGER                       :: istart,iend
328    CHARACTER (len = 20)          :: modname = 'fromcpl'
329    CHARACTER (len = 80)          :: abort_message
330    REAL, DIMENSION(iim*jj_nb)    :: field
331
332!************************************************************************************
[1152]333    WRITE (lunout,*) ' '
334    WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
335    WRITE (lunout,*) ' '
[782]336   
337    istart=ii_begin
338    IF (is_south_pole) THEN
339       iend=(jj_end-jj_begin)*iim+iim
340    ELSE
341       iend=(jj_end-jj_begin)*iim+ii_end
342    ENDIF
343   
[1152]344    DO i = 1, maxrecv
345      IF (inforecv(i)%action) THEN
346          field(:) = -99999.
347          CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror)
348          tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
[782]349       
[1152]350          IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
351             ierror.NE.PRISM_FromRest &
352             .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
353             .AND. ierror.NE.PRISM_FromRestOut) THEN
354              WRITE (lunout,*)  'Error with receiving filed : ', inforecv(i)%name, ktime   
355              abort_message=' Problem in prism_get_proto '
356              CALL abort_gcm(modname,abort_message,1)
357          ENDIF
358      ENDIF
[782]359    END DO
360   
361   
362  END SUBROUTINE fromcpl
363
364!
365!************************************************************************************
366!
367
368  SUBROUTINE intocpl(ktime, last, tab_put)
369! ======================================================================
370! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
371! atmospheric coupling fields to the coupler with the psmile library.
372! IF last time step, writes output fields to binary files.
373! ======================================================================
374!
375!
[793]376    INCLUDE "dimensions.h"
[1152]377    INCLUDE "iniprint.h"
[782]378! Input arguments
379!************************************************************************************
[1152]380    INTEGER, INTENT(IN)                              :: ktime
381    LOGICAL, INTENT(IN)                              :: last
382    REAL, DIMENSION(iim, jj_nb, maxsend), INTENT(IN) :: tab_put
[782]383
384! Local variables
385!************************************************************************************
[987]386    LOGICAL                          :: checkout
387    INTEGER                          :: istart,iend
388    INTEGER                          :: wstart,wend
389    INTEGER                          :: ierror, i
390    REAL, DIMENSION(iim*jj_nb)       :: field
391    CHARACTER (len = 20),PARAMETER   :: modname = 'intocpl'
392    CHARACTER (len = 80)             :: abort_message
[782]393
394!************************************************************************************
[987]395    checkout=.FALSE.
[782]396
[1152]397    WRITE(lunout,*) ' '
398    WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
399    WRITE(lunout,*) 'last = ', last
400    WRITE(lunout,*)
[782]401
402
403    istart=ii_begin
404    IF (is_south_pole) THEN
405       iend=(jj_end-jj_begin)*iim+iim
406    ELSE
407       iend=(jj_end-jj_begin)*iim+ii_end
408    ENDIF
409   
410    IF (checkout) THEN   
411       wstart=istart
412       wend=iend
413       IF (is_north_pole) wstart=istart+iim-1
414       IF (is_south_pole) wend=iend-iim+1
415       
[1152]416       DO i = 1, maxsend
417          IF (infosend(i)%action) THEN
418             field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
419             CALL writefield_phy(infosend(i)%name,field(wstart:wend),1)
420          END IF
421       END DO
422    END IF
423
[782]424!************************************************************************************
425! PRISM_PUT
426!************************************************************************************
427
[1152]428    DO i = 1, maxsend
429      IF (infosend(i)%action) THEN
430          field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
431          CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror)
432         
433          IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
434             .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
435             ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
436              WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime   
437              abort_message=' Problem in prism_put_proto '
438              CALL abort_gcm(modname,abort_message,1)
439          ENDIF
440      ENDIF
[782]441    END DO
442   
443!************************************************************************************
444! Finalize PSMILE for the case is_sequential, if parallel finalization is done
445! from Finalize_parallel in dyn3dpar/parallel.F90
446!************************************************************************************
447
448    IF (last) THEN
449       IF (is_sequential) THEN
450          CALL prism_terminate_proto(ierror)
451          IF (ierror .NE. PRISM_Ok) THEN
[1152]452             abort_message=' Problem in prism_terminate_proto '
[782]453             CALL abort_gcm(modname,abort_message,1)
454          ENDIF
455       ENDIF
456    ENDIF
457   
458   
459  END SUBROUTINE intocpl
460
461#endif
462 
463END MODULE oasis
Note: See TracBrowser for help on using the repository browser.