Index: /LMDZ.3.3/trunk/libf/phylmd/oasis.psmile =================================================================== --- /LMDZ.3.3/trunk/libf/phylmd/oasis.psmile (revision 481) +++ /LMDZ.3.3/trunk/libf/phylmd/oasis.psmile (revision 481) @@ -0,0 +1,429 @@ +! $Header$ + + MODULE oasis + +! Module contenant les routines pour l'initialisation du couplage, la +! lecture et l'ecriture des champs venant/transmis au coupleur +! + + IMPLICIT none + + PRIVATE + PUBLIC :: inicma, fromcpl, intocpl + + INTERFACE inicma + module procedure inicma + END INTERFACE + +#include "param_cou.h" + + integer, dimension(jpfldo2a), save :: in_var_id + integer, dimension(jpflda2o1+jpflda2o2), save :: il_out_var_id + CHARACTER (len=8), dimension(jpmaxfld), save :: cl_writ, cl_read + CHARACTER (len=8), dimension(jpmaxfld), save :: cl_f_writ, cl_f_read + +CONTAINS + +!**** +! +!**** *INICMA* - Initialize coupled mode communication for atmosphere +! and exchange some initial information with Oasis +! +! Rewrite to take the PRISM/psmile library into account +! LF 09/2003 +! +! Input: +! ----- +! im, jm: size of grid passed between gcm and coupler +! +! ----------------------------------------------------------- +! + SUBROUTINE inicma(im, jm) + + use mod_prism_proto + use mod_prism_def_partition_proto + + implicit none + +#include "param_cou.h" + +! +! parameters +! + integer :: im, jm +! +! local variables +! +! integers +! + integer :: comp_id + integer :: ierror + integer :: il_part_id + integer, dimension(:), allocatable :: ig_paral + integer, dimension(jpfldo2a) :: in_var_id + integer, dimension(jpflda2o1+jpflda2o2) :: il_out_var_id + integer, dimension(2) :: il_var_nodims + integer, dimension(4) :: il_var_actual_shape + integer :: il_var_type + integer :: nuout = 6 + integer :: jf +! characters +! + character (len = 6) :: clmodnam + character (len = 20),save :: modname = 'inicma' + character (len = 80) :: abort_message + +! +! ----------------------------------------------------------- +! +!* 1. Initializations +! --------------- +! + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ROUTINE INICMA' + WRITE(nuout,*) ' **************' + WRITE(nuout,*) ' ' + WRITE(nuout,*) ' ' +! +! Define the model name +! + clmodnam = 'lmdz.x' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp +! +! +! Here we go: psmile initialisation +! + call prism_init_comp_proto (comp_id, clmodnam, ierror) + + IF (ierror .ne. PRISM_Ok) THEN + abort_message=' Probleme init dans prism_init_comp ' + call abort_gcm(modname,abort_message,1) + ELSE + WRITE(nuout,*) 'inicma : init psmile ok ' + ENDIF + +! +! and domain decomposition +! +! monoproc case +! + allocate(ig_paral(3)) + ig_paral(1) = 0 + ig_paral(2) = 0 + ig_paral(3) = im * jm + + call prism_def_partition_proto (il_part_id, ig_paral, ierror) + deallocate(ig_paral) +! + IF (ierror .ne. PRISM_Ok) THEN + abort_message=' Probleme dans prism_def_partition ' + call abort_gcm(modname,abort_message,1) + ELSE + WRITE(nuout,*) 'inicma : decomposition domaine psmile ok ' + ENDIF + +! +! Field Declarations +! +! Define symbolic name for fields exchanged from atmos to coupler, +! must be the same as (1) of the field definition in namcouple: +! + cl_writ(1)='COSHFICE' + cl_writ(2)='COSHFOCE' + cl_writ(3)='CONSFICE' + cl_writ(4)='CONSFOCE' + cl_writ(5)='CODFLXDT' + cl_writ(6)='COTFSICE' + cl_writ(7)='COTFSOCE' + cl_writ(8)='COTOLPSU' + cl_writ(9)='COTOSPSU' + cl_writ(10)='CORUNCOA' + cl_writ(11)='CORIVFLU' + cl_writ(12)='COCALVIN' + cl_writ(13)='COTAUXXU' + cl_writ(14)='COTAUYYU' + cl_writ(15)='COTAUZZU' + cl_writ(16)='COTAUXXV' + cl_writ(17)='COTAUYYV' + cl_writ(18)='COTAUZZV' +! +! Define symbolic name for fields exchanged from coupler to atmosphere, +! must be the same as (2) of the field definition in namcouple: +! + cl_read(1)='SISUTESW' + cl_read(2)='SIICECOV' + cl_read(3)='SIICEALW' + cl_read(4)='SIICTEMW' + + il_var_nodims(1) = 2 + il_var_nodims(2) = 1 + + il_var_actual_shape(1) = 1 + il_var_actual_shape(2) = im + il_var_actual_shape(3) = 1 + il_var_actual_shape(4) = jm + + il_var_type = PRISM_Real +! +! Oceanic Fields +! + DO jf=1, jpfldo2a + call prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, & +& il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, & +& ierror) + IF (ierror .ne. PRISM_Ok) THEN + abort_message=' Probleme init dans prism_def_var_proto ' + call abort_gcm(modname,abort_message,1) + ENDIF + END DO +! +! Atmospheric Fields +! + DO jf=1, jpflda2o1+jpflda2o2 + call prism_def_var_proto(il_out_var_id(jf), cl_writ(jf), il_part_id, & +& il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, & +& ierror) + IF (ierror .ne. PRISM_Ok) THEN + abort_message=' Probleme init dans prism_def_var_proto ' + call abort_gcm(modname,abort_message,1) + ENDIF + END DO +! +! End +! + call prism_enddef_proto(ierror) + IF (ierror .ne. PRISM_Ok) THEN + abort_message=' Probleme init dans prism_ endef_proto' + call abort_gcm(modname,abort_message,1) + ELSE + WRITE(nuout,*) 'inicma : endef psmile ok ' + ENDIF + + END SUBROUTINE inicma + + SUBROUTINE fromcpl(kt, im, jm, sst, gla, tice, albedo) +! ====================================================================== +! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST +! and Sea-Ice provided by the coupler. Adaptation to psmile library +!====================================================================== + + use mod_prism_proto + use mod_prism_get_proto + + IMPLICIT none + +! +! parametres +! + integer :: im, jm, kt + real, dimension(im, jm) :: sst ! sea-surface-temperature + real, dimension(im, jm) :: gla ! sea-ice + real, dimension(im, jm) :: tice ! temp glace + real, dimension(im, jm) :: albedo ! albedo glace +! +! local variables +! + integer :: nuout = 6 ! listing output unit + integer :: ierror + character (len = 20),save :: modname = 'fromcpl' + character (len = 80) :: abort_message +! +#include "param_cou.h" +! +! + WRITE (nuout,*) ' ' + WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt + WRITE (nuout,*) ' ' + CALL flush (nuout) + + call prism_get_proto(in_var_id(1), kt, sst, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_read(1), kt + abort_message=' Probleme dans prism_get_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_get_proto(in_var_id(2), kt, gla, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_read(2), kt + abort_message=' Probleme dans prism_get_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_get_proto(in_var_id(3), kt, albedo, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_read(3), kt + abort_message=' Probleme dans prism_get_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_get_proto(in_var_id(4), kt, tice, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_read(4), kt + abort_message=' Probleme dans prism_get_proto ' + call abort_gcm(modname,abort_message,1) + endif + +! + RETURN + END SUBROUTINE fromcpl + + SUBROUTINE intocpl(kt, im, jm, fsolice, fsolwat, fnsolice, fnsolwat, & + & fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, & + & calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v & + & , last) +! ====================================================================== +! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the +! atmospheric coupling fields to the coupler with the psmile library. +! IF last time step, writes output fields to binary files. +! ====================================================================== + + use mod_prism_proto + use mod_prism_put_proto + + IMPLICIT NONE + +! +! parametres +! + integer :: kt, im, jm + real, dimension(im, jm) :: fsolice, fsolwat, fnsolwat, fnsolice + real, dimension(im, jm) :: fnsicedt, evice, evwat, lpre, spre + real, dimension(im, jm) :: dirunoff, rivrunoff, calving + real, dimension(im, jm) :: tauxx_u, tauxx_v, tauyy_u + real, dimension(im, jm) :: tauyy_v, tauzz_u, tauzz_v + logical :: last +! +! local +! + integer, parameter :: nuout = 6 + integer :: ierror + character (len = 20),save :: modname = 'intocpl' + character (len = 80) :: abort_message +! +! + WRITE(nuout,*) ' ' + WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt + WRITE(nuout,*) 'last ', last + WRITE(nuout,*) + + call prism_put_proto(il_out_var_id(1), kt, fsolice, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(1), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(2), kt, fsolwat, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(2), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(3), kt, fnsolice, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(3), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(4), kt, fnsolwat, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(4), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(5), kt, fnsicedt, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(5), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(6), kt, evice, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(6), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(7), kt, evwat, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(7), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(8), kt, lpre, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(8), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(9), kt, spre, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(9), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(10), kt, dirunoff, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(10), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(11), kt, rivrunoff, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(11), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(12), kt, calving, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(12), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(13), kt, tauxx_u, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(13), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(14), kt, tauyy_u, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(14), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(15), kt, tauzz_u, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(15), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(16), kt, tauxx_v, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(16), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(17), kt, tauyy_v, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(17), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + call prism_put_proto(il_out_var_id(18), kt, tauzz_v, ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(18), kt + abort_message=' Probleme dans prism_put_proto ' + call abort_gcm(modname,abort_message,1) + endif + + if (last) then + call prism_terminate_proto(ierror) + IF (ierror .ne. PRISM_Ok) THEN + WRITE (nuout,*) cl_writ(18), kt + abort_message=' Probleme dans prism_terminate_proto ' + call abort_gcm(modname,abort_message,1) + endif + endif + + + RETURN + END SUBROUTINE intocpl + + END MODULE oasis