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

Last change on this file since 1237 was 1227, checked in by jghattas, 15 years ago
  • Inclusion d'un premier version du cycle de carbon dans LMDZ. Attention

!! Il s'agit d'un version ou les nouveaux cles cycle_carbon_tr et
cycle_carbon_cpl ne sont pas teste. Avec les ancinenes parametres le
modele donne les memes resultats qu'avant. L'interface avec ORCHIDEE n'a
pas encore etait modifie.

  • physiq.F, phys_cal_mod.F90 : ajout d'un nouveau module qui contient qq parametres pour le calendrier et le pas de temps acutelle de la physiq. Ce module pourrait etre elargie plus tard / LF + JG


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