source: LMDZ.3.3/branches/rel-LF/libf/phylmd/oasis.psmile @ 520

Last change on this file since 520 was 500, checked in by (none), 21 years ago

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