! MODULE oasis ! ! This module contains subroutines for initialization, sending and receiving ! towards the coupler OASIS3. It also contains some parameters for the coupling. ! ! This module should always be compiled. With the coupler OASIS3 available the cpp key ! CPP_COUPLE should be set and the entier of this file will then be compiled. ! In a forced mode CPP_COUPLE should not be defined and the compilation ends before ! the CONTAINS, without compiling the subroutines. ! USE dimphy USE mod_phys_lmdz_para USE write_field_phy #ifdef CPP_COUPLE USE mod_prism_proto USE mod_prism_def_partition_proto USE mod_prism_get_proto USE mod_prism_put_proto #endif IMPLICIT NONE ! Maximum number of fields exchanged between ocean and atmosphere INTEGER, PARAMETER :: jpmaxfld=40 ! Number of fields exchanged from atmosphere to ocean via flx.F INTEGER, PARAMETER :: jpflda2o1=13 ! Number of fields exchanged from atmosphere to ocean via tau.F INTEGER, PARAMETER :: jpflda2o2=6 ! Number of fields exchanged from ocean to atmosphere INTEGER :: jpfldo2a CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE :: cl_read !$OMP THREADPRIVATE(cl_read) CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE :: cl_writ !$OMP THREADPRIVATE(cl_writ) INTEGER, DIMENSION(jpmaxfld), SAVE, PRIVATE :: in_var_id !$OMP THREADPRIVATE(in_var_id) INTEGER, DIMENSION(jpflda2o1+jpflda2o2), SAVE, PRIVATE :: out_var_id !$OMP THREADPRIVATE(out_var_id) LOGICAL :: cpl_current #ifdef CPP_COUPLE CONTAINS SUBROUTINE inicma !************************************************************************************ !**** *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 ! USE IOIPSL USE surface_data, ONLY : version_ocean INCLUDE "dimensions.h" ! Local variables !************************************************************************************ INTEGER :: comp_id INTEGER :: ierror, il_commlocal INTEGER :: il_part_id INTEGER, DIMENSION(3) :: ig_paral INTEGER, DIMENSION(2) :: il_var_nodims INTEGER, DIMENSION(4) :: il_var_actual_shape INTEGER :: il_var_type INTEGER :: nuout = 6 INTEGER :: jf CHARACTER (len = 6) :: clmodnam CHARACTER (len = 20) :: modname = 'inicma' CHARACTER (len = 80) :: abort_message LOGICAL :: cpl_current_omp !* 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 !************************************************************************************ ! Define if coupling ocean currents or not !************************************************************************************ !$OMP MASTER cpl_current_omp = .FALSE. CALL getin('cpl_current', cpl_current_omp) !$OMP END MASTER !$OMP BARRIER cpl_current = cpl_current_omp WRITE(nuout,*) 'Couple ocean currents, cpl_current = ',cpl_current IF (cpl_current) THEN jpfldo2a=7 ELSE jpfldo2a=4 END IF !************************************************************************************ ! Here we go: psmile initialisation !************************************************************************************ IF (is_sequential) THEN 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 ENDIF CALL prism_get_localcomm_proto (il_commlocal, ierror) !************************************************************************************ ! Domain decomposition !************************************************************************************ ig_paral(1) = 1 ! apple partition for // ig_paral(2) = (jj_begin-1)*iim+ii_begin-1 ! offset ig_paral(3) = (jj_end*iim+ii_end) - (jj_begin*iim+ii_begin) + 1 IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1 WRITE(nuout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3) ierror=PRISM_Ok CALL prism_def_partition_proto (il_part_id, ig_paral, ierror) 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: ! ! Initialization cl_writ(:)='NOFLDATM' cl_writ(1)='COTAUXXU' cl_writ(2)='COTAUYYU' cl_writ(3)='COTAUZZU' cl_writ(4)='COTAUXXV' cl_writ(5)='COTAUYYV' cl_writ(6)='COTAUZZV' cl_writ(7)='COWINDSP' cl_writ(8)='COSHFICE' cl_writ(9)='COSHFOCE' cl_writ(10)='CONSFICE' cl_writ(11)='CONSFOCE' cl_writ(12)='CODFLXDT' IF (version_ocean=='nemo') THEN cl_writ(13)='COEMPSIC' cl_writ(14)='CONESOPR' cl_writ(15)='COEMPOCE' cl_writ(16)='COICEVAP' cl_writ(17)='COCALVIN' cl_writ(18)='COLIQRUN' ELSE IF (version_ocean=='opa8') THEN 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' ENDIF ! ! Define symbolic name for fields exchanged from coupler to atmosphere, ! must be the same as (2) of the field definition in namcouple: ! ! Initialization cl_read(:)='NOFLDATM' cl_read(1)='SISUTESW' cl_read(2)='SIICECOV' cl_read(3)='SIICEALW' cl_read(4)='SIICTEMW' IF (cpl_current) THEN cl_read(5)='CURRENTX' cl_read(6)='CURRENTY' cl_read(7)='CURRENTZ' END IF il_var_nodims(1) = 2 il_var_nodims(2) = 1 il_var_actual_shape(1) = 1 il_var_actual_shape(2) = iim il_var_actual_shape(3) = 1 il_var_actual_shape(4) = jjm+1 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(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 definition !************************************************************************************ 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(ktime, tab_get) ! ====================================================================== ! 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 !====================================================================== ! INCLUDE "dimensions.h" ! Input arguments !************************************************************************************ INTEGER, INTENT(IN) :: ktime ! Output arguments !************************************************************************************ REAL, DIMENSION(iim, jj_nb,jpfldo2a), INTENT(OUT) :: tab_get ! Local variables !************************************************************************************ INTEGER :: nuout = 6 ! listing output unit INTEGER :: ierror, i INTEGER :: istart,iend CHARACTER (len = 20) :: modname = 'fromcpl' CHARACTER (len = 80) :: abort_message REAL, DIMENSION(iim*jj_nb) :: field !************************************************************************************ WRITE (nuout,*) ' ' WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime WRITE (nuout,*) ' ' CALL flush (nuout) istart=ii_begin IF (is_south_pole) THEN iend=(jj_end-jj_begin)*iim+iim ELSE iend=(jj_end-jj_begin)*iim+ii_end ENDIF DO i = 1, jpfldo2a field(:) = -99999. CALL prism_get_proto(in_var_id(i), ktime, field(istart:iend), ierror) tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/)) 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(i), ktime abort_message=' Probleme dans prism_get_proto ' CALL abort_gcm(modname,abort_message,1) ENDIF END DO END SUBROUTINE fromcpl ! !************************************************************************************ ! SUBROUTINE intocpl(ktime, last, tab_put) ! ====================================================================== ! 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. ! ====================================================================== ! ! INCLUDE "dimensions.h" ! Input arguments !************************************************************************************ INTEGER, INTENT(IN) :: ktime LOGICAL, INTENT(IN) :: last REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2), INTENT(IN) :: tab_put ! Local variables !************************************************************************************ LOGICAL :: checkout INTEGER :: istart,iend INTEGER :: wstart,wend INTEGER, PARAMETER :: nuout = 6 INTEGER :: ierror, i REAL, DIMENSION(iim*jj_nb) :: field CHARACTER (len = 20),PARAMETER :: modname = 'intocpl' CHARACTER (len = 80) :: abort_message !************************************************************************************ checkout=.FALSE. WRITE(nuout,*) ' ' WRITE(nuout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime WRITE(nuout,*) 'last ', last WRITE(nuout,*) istart=ii_begin IF (is_south_pole) THEN iend=(jj_end-jj_begin)*iim+iim ELSE iend=(jj_end-jj_begin)*iim+ii_end ENDIF IF (checkout) THEN wstart=istart wend=iend IF (is_north_pole) wstart=istart+iim-1 IF (is_south_pole) wend=iend-iim+1 field = RESHAPE(tab_put(:,:,8),(/iim*jj_nb/)) CALL writeField_phy("fsolice",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,9),(/iim*jj_nb/)) CALL writeField_phy("fsolwat",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,10),(/iim*jj_nb/)) CALL writeField_phy("fnsolice",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,11),(/iim*jj_nb/)) CALL writeField_phy("fnsolwat",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,12),(/iim*jj_nb/)) CALL writeField_phy("fnsicedt",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,13),(/iim*jj_nb/)) CALL writeField_phy("evice",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,14),(/iim*jj_nb/)) CALL writeField_phy("evwat",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,15),(/iim*jj_nb/)) CALL writeField_phy("lpre",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,16),(/iim*jj_nb/)) CALL writeField_phy("spre",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,17),(/iim*jj_nb/)) CALL writeField_phy("dirunoff",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,18),(/iim*jj_nb/)) CALL writeField_phy("rivrunoff",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,19),(/iim*jj_nb/)) CALL writeField_phy("calving",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,1),(/iim*jj_nb/)) CALL writeField_phy("tauxx_u",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,2),(/iim*jj_nb/)) CALL writeField_phy("tauyy_u",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,3),(/iim*jj_nb/)) CALL writeField_phy("tauzz_u",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,4),(/iim*jj_nb/)) CALL writeField_phy("tauxx_v",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,5),(/iim*jj_nb/)) CALL writeField_phy("tauyy_v",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,6),(/iim*jj_nb/)) CALL writeField_phy("tauzz_v",field(wstart:wend),1) field = RESHAPE(tab_put(:,:,7),(/iim*jj_nb/)) CALL writeField_phy("windsp",field(wstart:wend),1) ENDIF !************************************************************************************ ! PRISM_PUT !************************************************************************************ DO i = 1, jpflda2o1+jpflda2o2 field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/)) CALL prism_put_proto(out_var_id(i), ktime, field(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(i), ktime abort_message=' Probleme dans prism_put_proto ' CALL abort_gcm(modname,abort_message,1) ENDIF END DO !************************************************************************************ ! Finalize PSMILE for the case is_sequential, if parallel finalization is done ! from Finalize_parallel in dyn3dpar/parallel.F90 !************************************************************************************ IF (last) THEN IF (is_sequential) 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 END SUBROUTINE intocpl #endif END MODULE oasis