source: LMDZ5/trunk/libf/phylmd/oasis.F90 @ 1998

Last change on this file since 1998 was 1997, checked in by acaubel, 11 years ago

SAVE attribute was missing to run on OpenMP mode.
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 18.0 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 of Oasis-MCT coupler
18#if defined CPP_OMCT
19  USE mod_prism
20! Use of Oasis3 coupler
21#else
22  USE mod_prism_proto
23  USE mod_prism_def_partition_proto
24  USE mod_prism_get_proto
25  USE mod_prism_put_proto
26#endif
27#endif
28 
29  IMPLICIT NONE
30 
31  ! Id for fields sent to ocean
32  INTEGER, PARAMETER :: ids_tauxxu = 1
33  INTEGER, PARAMETER :: ids_tauyyu = 2
34  INTEGER, PARAMETER :: ids_tauzzu = 3
35  INTEGER, PARAMETER :: ids_tauxxv = 4
36  INTEGER, PARAMETER :: ids_tauyyv = 5
37  INTEGER, PARAMETER :: ids_tauzzv = 6
38  INTEGER, PARAMETER :: ids_windsp = 7
39  INTEGER, PARAMETER :: ids_shfice = 8
40  INTEGER, PARAMETER :: ids_shfoce = 9
41  INTEGER, PARAMETER :: ids_shftot = 10
42  INTEGER, PARAMETER :: ids_nsfice = 11
43  INTEGER, PARAMETER :: ids_nsfoce = 12
44  INTEGER, PARAMETER :: ids_nsftot = 13
45  INTEGER, PARAMETER :: ids_dflxdt = 14
46  INTEGER, PARAMETER :: ids_totrai = 15
47  INTEGER, PARAMETER :: ids_totsno = 16
48  INTEGER, PARAMETER :: ids_toteva = 17
49  INTEGER, PARAMETER :: ids_icevap = 18
50  INTEGER, PARAMETER :: ids_ocevap = 19
51  INTEGER, PARAMETER :: ids_calvin = 20
52  INTEGER, PARAMETER :: ids_liqrun = 21
53  INTEGER, PARAMETER :: ids_runcoa = 22
54  INTEGER, PARAMETER :: ids_rivflu = 23
55  INTEGER, PARAMETER :: ids_atmco2 = 24
56  INTEGER, PARAMETER :: ids_taumod = 25
57  INTEGER, PARAMETER :: maxsend    = 25  ! Maximum number of fields to send
58 
59  ! Id for fields received from ocean
60  INTEGER, PARAMETER :: idr_sisutw = 1
61  INTEGER, PARAMETER :: idr_icecov = 2
62  INTEGER, PARAMETER :: idr_icealw = 3
63  INTEGER, PARAMETER :: idr_icetem = 4
64  INTEGER, PARAMETER :: idr_curenx = 5
65  INTEGER, PARAMETER :: idr_cureny = 6
66  INTEGER, PARAMETER :: idr_curenz = 7
67  INTEGER, PARAMETER :: idr_oceco2 = 8
68  INTEGER, PARAMETER :: maxrecv    = 8  ! Maximum number of fields to receive
69 
70
71  TYPE, PUBLIC ::   FLD_CPL            ! Type for coupling field information
72     CHARACTER(len = 8) ::   name      ! Name of the coupling field   
73     LOGICAL            ::   action    ! To be exchanged or not
74     INTEGER            ::   nid       ! Id of the field
75  END TYPE FLD_CPL
76
77  TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend   ! Information for sending coupling fields
78  TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv   ! Information for receiving coupling fields
79 
80  LOGICAL,SAVE :: cpl_current
81!$OMP THREADPRIVATE(cpl_current)
82
83#ifdef CPP_COUPLE
84
85CONTAINS
86
87  SUBROUTINE inicma
88!************************************************************************************
89!**** *INICMA*  - Initialize coupled mode communication for atmosphere
90!                 and exchange some initial information with Oasis
91!
92!     Rewrite to take the PRISM/psmile library into account
93!     LF 09/2003
94!
95    USE IOIPSL
96    USE surface_data, ONLY : version_ocean
97    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
98
99    INCLUDE "dimensions.h"
100    INCLUDE "iniprint.h"
101
102! Local variables
103!************************************************************************************
104    INTEGER                            :: comp_id
105    INTEGER                            :: ierror, il_commlocal
106    INTEGER                            :: il_part_id
107    INTEGER, DIMENSION(3)              :: ig_paral
108    INTEGER, DIMENSION(2)              :: il_var_nodims
109    INTEGER, DIMENSION(4)              :: il_var_actual_shape
110    INTEGER                            :: il_var_type
111    INTEGER                            :: jf
112    CHARACTER (len = 6)                :: clmodnam
113    CHARACTER (len = 20)               :: modname = 'inicma'
114    CHARACTER (len = 80)               :: abort_message
115    LOGICAL, SAVE                      :: cpl_current_omp
116
117!*    1. Initializations
118!        ---------------
119!************************************************************************************
120    WRITE(lunout,*) ' '
121    WRITE(lunout,*) ' '
122    WRITE(lunout,*) ' ROUTINE INICMA'
123    WRITE(lunout,*) ' **************'
124    WRITE(lunout,*) ' '
125    WRITE(lunout,*) ' '
126
127!
128! Define the model name
129!
130    clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
131
132
133!************************************************************************************
134! Define if coupling ocean currents or not
135!************************************************************************************
136!$OMP MASTER
137    cpl_current_omp = .FALSE.
138    CALL getin('cpl_current', cpl_current_omp)
139!$OMP END MASTER
140!$OMP BARRIER
141    cpl_current = cpl_current_omp
142    WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current
143
144!************************************************************************************
145! Define coupling variables
146!************************************************************************************
147
148! Atmospheric variables to send
149
150!$OMP MASTER
151    infosend(:)%action = .FALSE.
152
153    infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU'
154    infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU'
155    infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU'
156    infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV'
157    infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV'
158    infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV'
159    infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP'
160    infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE'
161    infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE'
162    infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT'
163    infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN'
164   
165    IF (version_ocean=='nemo') THEN
166        infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX'
167        infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX'
168        infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI'
169        infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO'
170        infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA'
171        infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP'
172        infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN'
173        infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD'
174        IF (carbon_cycle_cpl) THEN
175            infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2'
176        ENDIF
177       
178    ELSE IF (version_ocean=='opa8') THEN
179        infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE'
180        infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE'
181        infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE'
182        infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE'
183        infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU'
184        infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU'
185        infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA'
186        infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU'
187   ENDIF
188       
189! Oceanic variables to receive
190
191   inforecv(:)%action = .FALSE.
192
193   inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW'
194   inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV'
195   inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW'
196   inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW'
197   
198   IF (cpl_current ) THEN
199       inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX'
200       inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY'
201       inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ'
202   ENDIF
203
204   IF (carbon_cycle_cpl ) THEN
205       inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX'
206   ENDIF
207
208!************************************************************************************
209! Here we go: psmile initialisation
210!************************************************************************************
211    IF (is_sequential) THEN
212       CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
213       
214       IF (ierror .NE. PRISM_Ok) THEN
215          abort_message=' Probleme init dans prism_init_comp '
216          CALL abort_gcm(modname,abort_message,1)
217       ELSE
218          WRITE(lunout,*) 'inicma : init psmile ok '
219       ENDIF
220    ENDIF
221
222    CALL prism_get_localcomm_proto (il_commlocal, ierror)
223!************************************************************************************
224! Domain decomposition
225!************************************************************************************
226    ig_paral(1) = 1                            ! apple partition for //
227    ig_paral(2) = (jj_begin-1)*iim+ii_begin-1  ! offset
228    ig_paral(3) = (jj_end*iim+ii_end) - (jj_begin*iim+ii_begin) + 1
229
230    IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
231    WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
232   
233    ierror=PRISM_Ok
234    CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
235
236    IF (ierror .NE. PRISM_Ok) THEN
237       abort_message=' Probleme dans prism_def_partition '
238       CALL abort_gcm(modname,abort_message,1)
239    ELSE
240       WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
241    ENDIF
242
243    il_var_nodims(1) = 2
244    il_var_nodims(2) = 1
245
246    il_var_actual_shape(1) = 1
247    il_var_actual_shape(2) = iim
248    il_var_actual_shape(3) = 1
249    il_var_actual_shape(4) = jjm+1
250   
251    il_var_type = PRISM_Real
252
253!************************************************************************************
254! Oceanic Fields to receive
255! Loop over all possible variables
256!************************************************************************************
257    DO jf=1, maxrecv
258       IF (inforecv(jf)%action) THEN
259          CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, &
260               il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
261               ierror)
262          IF (ierror .NE. PRISM_Ok) THEN
263             WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
264                  inforecv(jf)%name
265             abort_message=' Problem in call to prism_def_var_proto for fields to receive'
266             CALL abort_gcm(modname,abort_message,1)
267          ENDIF
268       ENDIF
269    END DO
270   
271!************************************************************************************
272! Atmospheric Fields to send
273! Loop over all possible variables
274!************************************************************************************
275    DO jf=1,maxsend
276       IF (infosend(jf)%action) THEN
277          CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
278               il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
279               ierror)
280          IF (ierror .NE. PRISM_Ok) THEN
281             WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
282                  infosend(jf)%name
283             abort_message=' Problem in call to prism_def_var_proto for fields to send'
284             CALL abort_gcm(modname,abort_message,1)
285          ENDIF
286       ENDIF
287    END DO
288   
289!************************************************************************************
290! End definition
291!************************************************************************************
292    CALL prism_enddef_proto(ierror)
293    IF (ierror .NE. PRISM_Ok) THEN
294       abort_message=' Problem in call to prism_endef_proto'
295       CALL abort_gcm(modname,abort_message,1)
296    ELSE
297       WRITE(lunout,*) 'inicma : endef psmile ok '
298    ENDIF
299
300!$OMP END MASTER
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!
314    INCLUDE "dimensions.h"
315    INCLUDE "iniprint.h"
316! Input arguments
317!************************************************************************************
318    INTEGER, INTENT(IN)                               ::  ktime
319
320! Output arguments
321!************************************************************************************
322    REAL, DIMENSION(iim, jj_nb,maxrecv), INTENT(OUT) :: tab_get
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!************************************************************************************
333    WRITE (lunout,*) ' '
334    WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
335    WRITE (lunout,*) ' '
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   
344    DO i = 1, maxrecv
345      IF (inforecv(i)%action .AND. inforecv(i)%nid .NE. -1) 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/))
349       
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
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!
376    INCLUDE "dimensions.h"
377    INCLUDE "iniprint.h"
378! Input arguments
379!************************************************************************************
380    INTEGER, INTENT(IN)                              :: ktime
381    LOGICAL, INTENT(IN)                              :: last
382    REAL, DIMENSION(iim, jj_nb, maxsend), INTENT(IN) :: tab_put
383
384! Local variables
385!************************************************************************************
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
393
394!************************************************************************************
395    checkout=.FALSE.
396
397    WRITE(lunout,*) ' '
398    WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
399    WRITE(lunout,*) 'last = ', last
400    WRITE(lunout,*)
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       
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
424!************************************************************************************
425! PRISM_PUT
426!************************************************************************************
427
428    DO i = 1, maxsend
429      IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) 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
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
452             abort_message=' Problem in prism_terminate_proto '
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.