source: LMDZ4/branches/IPSL-CM4_IPCC_patches/libf/phylmd/oasis.psmile @ 1905

Last change on this file since 1905 was 524, checked in by lmdzadmin, 20 years ago

Initial revision
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 13.2 KB
Line 
1!
2! $Header$
3!
4
5  MODULE oasis
6
7! Module contenant les routines pour l'initialisation du couplage, la
8! lecture et l'ecriture des champs venant/transmis au coupleur
9!
10
11  IMPLICIT none
12
13  PRIVATE
14  PUBLIC :: inicma, fromcpl, intocpl
15
16  INTERFACE inicma
17    module procedure inicma
18  END INTERFACE 
19
20#include "param_cou.h"
21
22   integer, dimension(jpfldo2a), save              :: in_var_id
23   integer, dimension(jpflda2o1+jpflda2o2), save  :: il_out_var_id
24   CHARACTER (len=8), dimension(jpmaxfld), save   :: cl_writ, cl_read
25   CHARACTER (len=8), dimension(jpmaxfld), save   :: cl_f_writ, cl_f_read
26
27CONTAINS
28
29!****
30!
31!**** *INICMA*  - Initialize coupled mode communication for atmosphere
32!                 and exchange some initial information with Oasis
33!
34!     Rewrite to take the PRISM/psmile library into account
35!     LF 09/2003
36!
37!     Input:
38!     -----
39!        im, jm: size of grid passed between gcm and coupler
40!
41!     -----------------------------------------------------------
42!
43   SUBROUTINE inicma(im, jm)
44
45   use mod_prism_proto
46   use mod_prism_def_partition_proto
47
48   implicit none
49
50#include "param_cou.h"
51
52!
53! parameters
54!
55   integer                  :: im, jm
56!
57! local variables
58!
59! integers
60!
61   integer                                  :: comp_id
62   integer                                  :: ierror
63   integer                                  :: il_part_id
64   integer, dimension(:), allocatable       :: ig_paral
65   integer, dimension(jpfldo2a)             :: in_var_id
66   integer, dimension(jpflda2o1+jpflda2o2)  :: il_out_var_id
67   integer, dimension(2)                    :: il_var_nodims
68   integer, dimension(4)                    :: il_var_actual_shape
69   integer                                  :: il_var_type
70   integer                                  :: nuout = 6
71   integer                                  :: jf
72! characters
73!
74   character (len = 6)        :: clmodnam
75   character (len = 20),save  :: modname = 'inicma'
76   character (len = 80)       :: abort_message
77   
78!
79!     -----------------------------------------------------------
80!
81!*    1. Initializations
82!        ---------------
83!
84   WRITE(nuout,*) ' '
85   WRITE(nuout,*) ' '
86   WRITE(nuout,*) ' ROUTINE INICMA'
87   WRITE(nuout,*) ' **************'
88   WRITE(nuout,*) ' '
89   WRITE(nuout,*) ' '
90!
91!     Define the model name
92!
93   clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
94!
95!
96! Here we go: psmile initialisation
97!
98   call prism_init_comp_proto (comp_id, clmodnam, ierror)
99
100   IF (ierror .ne. PRISM_Ok) THEN
101      abort_message=' Probleme init dans prism_init_comp '
102      call abort_gcm(modname,abort_message,1)
103   ELSE
104      WRITE(nuout,*) 'inicma : init psmile ok '
105   ENDIF
106
107!
108! and domain decomposition
109!
110! monoproc case
111!
112   allocate(ig_paral(3))
113   ig_paral(1) = 0
114   ig_paral(2) = 0
115   ig_paral(3) = im * jm
116
117   call prism_def_partition_proto (il_part_id, ig_paral, ierror)
118   deallocate(ig_paral)
119!
120   IF (ierror .ne. PRISM_Ok) THEN
121     abort_message=' Probleme dans prism_def_partition '
122     call abort_gcm(modname,abort_message,1)
123   ELSE
124     WRITE(nuout,*) 'inicma : decomposition domaine psmile ok '
125   ENDIF
126
127!
128! Field Declarations
129!
130!     Define symbolic name for fields exchanged from atmos to coupler,
131!         must be the same as (1) of the field  definition in namcouple:
132!
133   cl_writ(1)='COSHFICE'
134   cl_writ(2)='COSHFOCE'
135   cl_writ(3)='CONSFICE'
136   cl_writ(4)='CONSFOCE'
137   cl_writ(5)='CODFLXDT'
138   cl_writ(6)='COTFSICE'
139   cl_writ(7)='COTFSOCE'
140   cl_writ(8)='COTOLPSU'
141   cl_writ(9)='COTOSPSU'
142   cl_writ(10)='CORUNCOA'
143   cl_writ(11)='CORIVFLU'
144   cl_writ(12)='COCALVIN'
145   cl_writ(13)='COTAUXXU'
146   cl_writ(14)='COTAUYYU'
147   cl_writ(15)='COTAUZZU'
148   cl_writ(16)='COTAUXXV'
149   cl_writ(17)='COTAUYYV'
150   cl_writ(18)='COTAUZZV'
151!
152!     Define symbolic name for fields exchanged from coupler to atmosphere,
153!         must be the same as (2) of the field  definition in namcouple:
154!
155   cl_read(1)='SISUTESW'
156   cl_read(2)='SIICECOV'
157   cl_read(3)='SIICEALW'
158   cl_read(4)='SIICTEMW'
159
160   il_var_nodims(1) = 2
161   il_var_nodims(2) = 1
162
163   il_var_actual_shape(1) = 1
164   il_var_actual_shape(2) = im
165   il_var_actual_shape(3) = 1
166   il_var_actual_shape(4) = jm
167   
168   il_var_type = PRISM_Real
169!
170! Oceanic Fields
171!
172   DO jf=1, jpfldo2a
173     call prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
174&               il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
175&               ierror)
176     IF (ierror .ne. PRISM_Ok) THEN
177        abort_message=' Probleme init dans prism_def_var_proto '
178        call abort_gcm(modname,abort_message,1)
179     ENDIF
180   END DO
181!
182! Atmospheric Fields
183!
184   DO jf=1, jpflda2o1+jpflda2o2
185     call prism_def_var_proto(il_out_var_id(jf), cl_writ(jf), il_part_id, &
186&               il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
187&               ierror)
188     IF (ierror .ne. PRISM_Ok) THEN
189        abort_message=' Probleme init dans prism_def_var_proto '
190        call abort_gcm(modname,abort_message,1)
191     ENDIF
192   END DO
193!
194! End
195!
196   call prism_enddef_proto(ierror)
197   IF (ierror .ne. PRISM_Ok) THEN
198      abort_message=' Probleme init dans prism_ endef_proto'
199      call abort_gcm(modname,abort_message,1)
200   ELSE
201      WRITE(nuout,*) 'inicma : endef psmile ok '
202   ENDIF
203
204   END SUBROUTINE inicma
205
206   SUBROUTINE fromcpl(kt, im, jm, sst, gla, tice, albedo)
207! ======================================================================
208! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
209! and Sea-Ice provided by the coupler. Adaptation to psmile library
210!======================================================================
211
212   use mod_prism_proto
213   use mod_prism_get_proto
214
215   IMPLICIT none
216
217!
218! parametres
219!
220   integer                 :: im, jm, kt
221   real, dimension(im, jm)   :: sst            ! sea-surface-temperature
222   real, dimension(im, jm)   :: gla     ! sea-ice
223   real, dimension(im, jm)   :: tice    ! temp glace
224   real, dimension(im, jm)   :: albedo  ! albedo glace
225!
226! local variables
227!
228   integer                 :: nuout  = 6             ! listing output unit
229   integer                 :: ierror
230   character (len = 20),save  :: modname = 'fromcpl'
231   character (len = 80)       :: abort_message
232!
233#include "param_cou.h"
234!
235!
236   WRITE (nuout,*) ' '
237   WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt
238   WRITE (nuout,*) ' '
239   CALL flush (nuout)
240
241   call prism_get_proto(in_var_id(1), kt, sst, ierror)
242   IF (ierror .ne. PRISM_Ok) THEN
243     WRITE (nuout,*)  cl_read(1), kt   
244     abort_message=' Probleme dans prism_get_proto '
245     call abort_gcm(modname,abort_message,1)
246   endif
247   call prism_get_proto(in_var_id(2), kt, gla, ierror)
248   IF (ierror .ne. PRISM_Ok) THEN
249     WRITE (nuout,*)  cl_read(2), kt   
250     abort_message=' Probleme dans prism_get_proto '
251     call abort_gcm(modname,abort_message,1)
252   endif
253   call prism_get_proto(in_var_id(3), kt, albedo, ierror)
254   IF (ierror .ne. PRISM_Ok) THEN
255     WRITE (nuout,*)  cl_read(3), kt   
256     abort_message=' Probleme dans prism_get_proto '
257     call abort_gcm(modname,abort_message,1)
258   endif
259   call prism_get_proto(in_var_id(4), kt, tice, ierror)
260   IF (ierror .ne. PRISM_Ok) THEN
261     WRITE (nuout,*)  cl_read(4), kt   
262     abort_message=' Probleme dans prism_get_proto '
263     call abort_gcm(modname,abort_message,1)
264   endif
265
266!
267   RETURN
268   END SUBROUTINE fromcpl
269
270   SUBROUTINE intocpl(kt, im, jm, fsolice, fsolwat, fnsolice, fnsolwat, &
271 &    fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, &
272 &    calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v &
273 &    , last)
274! ======================================================================
275! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
276! atmospheric coupling fields to the coupler with the psmile library.
277! IF last time step, writes output fields to binary files.
278! ======================================================================
279
280   use mod_prism_proto
281   use mod_prism_put_proto
282
283   IMPLICIT NONE
284
285!
286! parametres
287!
288   integer               :: kt, im, jm
289   real, dimension(im, jm) :: fsolice, fsolwat, fnsolwat, fnsolice
290   real, dimension(im, jm) :: fnsicedt, evice, evwat, lpre, spre
291   real, dimension(im, jm) :: dirunoff, rivrunoff, calving
292   real, dimension(im, jm) :: tauxx_u, tauxx_v, tauyy_u
293   real, dimension(im, jm) :: tauyy_v, tauzz_u, tauzz_v
294   logical               :: last
295!
296! local
297!
298   integer, parameter    :: nuout = 6
299   integer               :: ierror
300   character (len = 20),save  :: modname = 'intocpl'
301   character (len = 80)       :: abort_message
302!
303!
304      WRITE(nuout,*) ' '
305      WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt
306      WRITE(nuout,*) 'last  ', last
307      WRITE(nuout,*)
308
309   call prism_put_proto(il_out_var_id(1), kt, fsolice, ierror)
310   IF (ierror .ne. PRISM_Ok) THEN
311     WRITE (nuout,*)  cl_writ(1), kt   
312     abort_message=' Probleme dans prism_put_proto '
313     call abort_gcm(modname,abort_message,1)
314   endif
315   call prism_put_proto(il_out_var_id(2), kt, fsolwat, ierror)
316   IF (ierror .ne. PRISM_Ok) THEN
317     WRITE (nuout,*)  cl_writ(2), kt   
318     abort_message=' Probleme dans prism_put_proto '
319     call abort_gcm(modname,abort_message,1)
320   endif
321   call prism_put_proto(il_out_var_id(3), kt, fnsolice, ierror)
322   IF (ierror .ne. PRISM_Ok) THEN
323     WRITE (nuout,*)  cl_writ(3), kt   
324     abort_message=' Probleme dans prism_put_proto '
325     call abort_gcm(modname,abort_message,1)
326   endif
327   call prism_put_proto(il_out_var_id(4), kt, fnsolwat, ierror)
328   IF (ierror .ne. PRISM_Ok) THEN
329     WRITE (nuout,*)  cl_writ(4), kt   
330     abort_message=' Probleme dans prism_put_proto '
331     call abort_gcm(modname,abort_message,1)
332   endif
333   call prism_put_proto(il_out_var_id(5), kt, fnsicedt, ierror)
334   IF (ierror .ne. PRISM_Ok) THEN
335     WRITE (nuout,*)  cl_writ(5), kt   
336     abort_message=' Probleme dans prism_put_proto '
337     call abort_gcm(modname,abort_message,1)
338   endif
339   call prism_put_proto(il_out_var_id(6), kt, evice, ierror)
340   IF (ierror .ne. PRISM_Ok) THEN
341     WRITE (nuout,*)  cl_writ(6), kt   
342     abort_message=' Probleme dans prism_put_proto '
343     call abort_gcm(modname,abort_message,1)
344   endif
345   call prism_put_proto(il_out_var_id(7), kt, evwat, ierror)
346   IF (ierror .ne. PRISM_Ok) THEN
347     WRITE (nuout,*)  cl_writ(7), kt   
348     abort_message=' Probleme dans prism_put_proto '
349     call abort_gcm(modname,abort_message,1)
350   endif
351   call prism_put_proto(il_out_var_id(8), kt, lpre, ierror)
352   IF (ierror .ne. PRISM_Ok) THEN
353     WRITE (nuout,*)  cl_writ(8), kt   
354     abort_message=' Probleme dans prism_put_proto '
355     call abort_gcm(modname,abort_message,1)
356   endif
357   call prism_put_proto(il_out_var_id(9), kt, spre, ierror)
358   IF (ierror .ne. PRISM_Ok) THEN
359     WRITE (nuout,*)  cl_writ(9), kt   
360     abort_message=' Probleme dans prism_put_proto '
361     call abort_gcm(modname,abort_message,1)
362   endif
363   call prism_put_proto(il_out_var_id(10), kt, dirunoff, ierror)
364   IF (ierror .ne. PRISM_Ok) THEN
365     WRITE (nuout,*)  cl_writ(10), kt   
366     abort_message=' Probleme dans prism_put_proto '
367     call abort_gcm(modname,abort_message,1)
368   endif
369   call prism_put_proto(il_out_var_id(11), kt, rivrunoff, ierror)
370   IF (ierror .ne. PRISM_Ok) THEN
371     WRITE (nuout,*)  cl_writ(11), kt   
372     abort_message=' Probleme dans prism_put_proto '
373     call abort_gcm(modname,abort_message,1)
374   endif
375   call prism_put_proto(il_out_var_id(12), kt, calving, ierror)
376   IF (ierror .ne. PRISM_Ok) THEN
377     WRITE (nuout,*)  cl_writ(12), kt   
378     abort_message=' Probleme dans prism_put_proto '
379     call abort_gcm(modname,abort_message,1)
380   endif
381   call prism_put_proto(il_out_var_id(13), kt, tauxx_u, ierror)
382   IF (ierror .ne. PRISM_Ok) THEN
383     WRITE (nuout,*)  cl_writ(13), kt   
384     abort_message=' Probleme dans prism_put_proto '
385     call abort_gcm(modname,abort_message,1)
386   endif
387   call prism_put_proto(il_out_var_id(14), kt, tauyy_u, ierror)
388   IF (ierror .ne. PRISM_Ok) THEN
389     WRITE (nuout,*)  cl_writ(14), kt   
390     abort_message=' Probleme dans prism_put_proto '
391     call abort_gcm(modname,abort_message,1)
392   endif
393   call prism_put_proto(il_out_var_id(15), kt, tauzz_u, ierror)
394   IF (ierror .ne. PRISM_Ok) THEN
395     WRITE (nuout,*)  cl_writ(15), kt   
396     abort_message=' Probleme dans prism_put_proto '
397     call abort_gcm(modname,abort_message,1)
398   endif
399   call prism_put_proto(il_out_var_id(16), kt, tauxx_v, ierror)
400   IF (ierror .ne. PRISM_Ok) THEN
401     WRITE (nuout,*)  cl_writ(16), kt   
402     abort_message=' Probleme dans prism_put_proto '
403     call abort_gcm(modname,abort_message,1)
404   endif
405   call prism_put_proto(il_out_var_id(17), kt, tauyy_v, ierror)
406   IF (ierror .ne. PRISM_Ok) THEN
407     WRITE (nuout,*)  cl_writ(17), kt   
408     abort_message=' Probleme dans prism_put_proto '
409     call abort_gcm(modname,abort_message,1)
410   endif
411   call prism_put_proto(il_out_var_id(18), kt, tauzz_v, ierror)
412   IF (ierror .ne. PRISM_Ok) THEN
413     WRITE (nuout,*)  cl_writ(18), kt   
414     abort_message=' Probleme dans prism_put_proto '
415     call abort_gcm(modname,abort_message,1)
416   endif
417
418   if (last) then
419     call prism_terminate_proto(ierror)
420     IF (ierror .ne. PRISM_Ok) THEN
421       WRITE (nuout,*)  cl_writ(18), kt   
422       abort_message=' Probleme dans prism_terminate_proto '
423       call abort_gcm(modname,abort_message,1)
424     endif
425   endif
426
427
428   RETURN
429   END SUBROUTINE intocpl
430
431   END MODULE oasis
Note: See TracBrowser for help on using the repository browser.