My Project
 All Classes Files Functions Variables Macros
oasis.F90
Go to the documentation of this file.
1 !
2 MODULE 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 
79 CONTAINS
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 
457 END MODULE oasis