source: trunk/libf/phylmd/oasis.F90 @ 1

Last change on this file since 1 was 1, checked in by emillour, 14 years ago

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