source: dynamico_lmdz/aquaplanet/LMDZ5/libf/phylmd/oasis.F90 @ 3814

Last change on this file since 3814 was 3814, checked in by ymipsl, 10 years ago

remove all dynamic dependency in LMDZ physics except for the include "dimensions.h"

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