! ! $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), public, 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 use dimphy implicit none #include "param_cou.h" ! ! parameters ! integer :: im, jm ! ! local variables ! ! integers ! integer :: comp_id integer :: ierror, il_commlocal integer :: il_part_id integer, dimension(:), allocatable :: ig_paral 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 ! !ym call prism_init_comp_proto (comp_id, clmodnam, ierror) !ym !ym IF (ierror .ne. PRISM_Ok) THEN !ym abort_message=' Probleme init dans prism_init_comp ' !ym call abort_gcm(modname,abort_message,1) !ym ELSE !ym WRITE(nuout,*) 'inicma : init psmile ok ' !ym ENDIF call prism_get_localcomm_proto (il_commlocal, ierror) ! ! and domain decomposition ! ! monoproc case ! allocate(ig_paral(3)) !ym ig_paral(1) = 0 !ym ig_paral(2) = 0 !ym ig_paral(3) = im * jm ig_paral(1) = 1 ! apple partition for // ig_paral(2) = (jjphy_begin-1)*im+iiphy_begin-1 ig_paral(3) = (jjphy_end*im+iiphy_end)-(jjphy_begin*im+iiphy_begin)+1 if (phy_rank==phy_size-1) ig_paral(3)=ig_paral(3)+im-1 print *,phy_rank,'ig_paral--->',ig_paral(2),ig_paral(3) ierror=PRISM_Ok 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)='COTAUXXU' cl_writ(2)='COTAUYYU' cl_writ(3)='COTAUZZU' cl_writ(4)='COTAUXXV' cl_writ(5)='COTAUYYV' cl_writ(6)='COTAUZZV' ! -- LOOP cl_writ(7)='COWINDSP' ! -- LOOP cl_writ(8)='COSHFICE' cl_writ(9)='COSHFOCE' cl_writ(10)='CONSFICE' cl_writ(11)='CONSFOCE' cl_writ(12)='CODFLXDT' cl_writ(13)='COTFSICE' cl_writ(14)='COTFSOCE' cl_writ(15)='COTOLPSU' cl_writ(16)='COTOSPSU' cl_writ(17)='CORUNCOA' cl_writ(18)='CORIVFLU' cl_writ(19)='COCALVIN' ! ! 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 use dimphy 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 integer :: istart,iend ! #include "param_cou.h" ! ! WRITE (nuout,*) ' ' WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt WRITE (nuout,*) ' ' CALL flush (nuout) istart=iiphy_begin if (phy_rank==phy_size-1) then iend=(jjphy_end-jjphy_begin)*im+im else iend=(jjphy_end-jjphy_begin)*im+iiphy_end endif call prism_get_proto(in_var_id(1), kt, sst(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. & & ierror.ne.PRISM_FromRest & & .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut & & .and. ierror.ne.PRISM_FromRestOut) 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(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. & & ierror.ne.PRISM_FromRest & & .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut & & .and. ierror.ne.PRISM_FromRestOut) 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(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. & & ierror.ne.PRISM_FromRest & & .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut & & .and. ierror.ne.PRISM_FromRestOut) 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(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. & & ierror.ne.PRISM_FromRest & & .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut & & .and. ierror.ne.PRISM_FromRestOut) 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, & ! -- LOOP & windsp, & ! -- LOOP & 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 use dimphy use write_field_phy 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 real, dimension(im*jm) :: windsp logical :: last logical :: checkout=.FALSE. integer :: istart,iend integer :: wstart,wend ! ! 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,*) istart=iiphy_begin if (phy_rank==phy_size-1) then iend=(jjphy_end-jjphy_begin)*im+im else iend=(jjphy_end-jjphy_begin)*im+iiphy_end endif IF (checkout) THEN wstart=istart wend=iend IF (phy_rank==0) wstart=istart+im-1 IF (phy_rank==phy_size-1) wend=iend-im+1 CALL writeField_phy("fsolice",fsolice(wstart:wend),1) CALL writeField_phy("fsolwat",fsolwat(wstart:wend),1) CALL writeField_phy("fnsolice",fnsolice(wstart:wend),1) CALL writeField_phy("fnsolwat",fnsolwat(wstart:wend),1) CALL writeField_phy("fnsicedt",fnsicedt(wstart:wend),1) CALL writeField_phy("evice",evice(wstart:wend),1) CALL writeField_phy("evwat",evwat(wstart:wend),1) CALL writeField_phy("lpre",lpre(wstart:wend),1) CALL writeField_phy("spre",spre(wstart:wend),1) CALL writeField_phy("dirunoff",dirunoff(wstart:wend),1) CALL writeField_phy("rivrunoff",rivrunoff(wstart:wend),1) CALL writeField_phy("calving",calving(wstart:wend),1) CALL writeField_phy("tauxx_u",tauxx_u(wstart:wend),1) CALL writeField_phy("tauyy_u",tauyy_u(wstart:wend),1) CALL writeField_phy("tauzz_u",tauzz_u(wstart:wend),1) CALL writeField_phy("tauxx_v",tauxx_v(wstart:wend),1) CALL writeField_phy("tauyy_v",tauyy_v(wstart:wend),1) CALL writeField_phy("tauzz_v",tauzz_v(wstart:wend),1) CALL writeField_phy("windsp",windsp(wstart:wend),1) ENDIF call prism_put_proto(il_out_var_id(8), kt, fsolice(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, fsolwat(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, fnsolice(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, fnsolwat(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, fnsicedt(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, evice(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, evwat(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, lpre(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, spre(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, dirunoff(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, rivrunoff(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN WRITE (nuout,*) cl_writ(18), kt abort_message=' Probleme dans prism_put_proto ' call abort_gcm(modname,abort_message,1) endif call prism_put_proto(il_out_var_id(19), kt, calving(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN WRITE (nuout,*) cl_writ(19), kt abort_message=' Probleme dans prism_put_proto ' call abort_gcm(modname,abort_message,1) endif call prism_put_proto(il_out_var_id(1), kt, tauxx_u(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, tauyy_u(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, tauzz_u(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, tauxx_v(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, tauyy_v(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, tauzz_v(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) 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, windsp(istart:iend), ierror) IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest & & .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. & & ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN WRITE (nuout,*) cl_writ(7), kt abort_message=' Probleme dans prism_put_proto ' call abort_gcm(modname,abort_message,1) endif if (last) then IF (monocpu) THEN call prism_terminate_proto(ierror) IF (ierror .ne. PRISM_Ok) THEN abort_message=' Probleme dans prism_terminate_proto ' call abort_gcm(modname,abort_message,1) endif ENDIF endif RETURN END SUBROUTINE intocpl END MODULE oasis