! #define TRACEBACK write (gol,'("in ",a," (",a,", line",i5,")")') rname, __FILE__, __LINE__; call goErr ! #define IF_NOTOK_RETURN(action) if (status/=0) then; TRACEBACK; action; return; end if #define IF_ERROR_RETURN(action) if (status >0) then; TRACEBACK; action; return; end if ! #include "tm5.inc" ! !----------------------------------------------------------------------------- ! TM5 ! !----------------------------------------------------------------------------- !BOP ! ! !MODULE: TMM_MF_PRISM ! ! !DESCRIPTION: Input/output of meteofiles : OASIS3/PRISM version. !\\ !\\ ! !INTERFACE: ! MODULE TMM_MF_PRISM ! ! !USES: ! use GO, only : gol, goPr, goErr, goBug, goLabel, TDate use TM5_Prism, only : TshRemap, comp_id use tm5_distgrid, only : dgrid, Get_DistGrid implicit none ! ! !PUBLIC MEMBER FUNCTIONS: ! public :: cf_overhead ! cloud fraction overhead public :: mfPrism_Init, mfPrism_Done ! init/done tools for reading MF public :: TMeteoFile_prism ! MF type for reading prism meteo public :: Init, Done, ReadRecord ! methods for MF type ! ! !PUBLIC DATA MEMBERS: ! character(len=*), parameter :: mname = 'module tmm_mf_prism' ! ! !PUBLIC TYPES: ! type TMeteoFile_prism type(TDate) :: tday ! reference date end type TMeteoFile_prism type(TshRemap), save :: shRemap2d, shRemap3d real, pointer :: spinf2d_sh_raw(:,:,:) integer :: itim_readrecord ! timer id ! ! !INTERFACE: ! interface Init module procedure mf_Init end interface interface Done module procedure mf_Done end interface interface ReadRecord #ifdef parallel_cplng module procedure mf_ReadRecord_parallel #else module procedure mf_ReadRecord #endif end interface ! ! !REVISION HISTORY: ! 16 Sep 2013 - Ph. Le Sager - doc, clean up, updated for TM5v4. Remove ! oasis4 stuff for clarity. ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ CONTAINS !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: MFPRISM_INIT ! ! !DESCRIPTION: Init tools for remapping spectral fields. Init timer. !\\ !\\ ! !INTERFACE: ! SUBROUTINE MFPRISM_INIT( status ) ! ! !USES: ! use GO, only : NewDate, GO_Timer_Def use TM5_Prism, only : Init, setup, ifs_shn ! ! !OUTPUT PARAMETERS: ! integer, intent(out) :: status ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/mfPrism_Init' integer :: icache integer :: fu logical :: opened real, allocatable :: ifs_sp(:) real, allocatable :: sh_raw(:,:,:) real, parameter :: spinf_nan = -1.2345 ! --- begin ----------------------------------------- ! ! spectral remapping ! call Init( shRemap2d, status ) IF_NOTOK_RETURN(status=1) call Init( shRemap3d, status ) IF_NOTOK_RETURN(status=1) nullify( spinf2d_sh_raw ) ! define timer (expected by tmm.F90) call GO_Timer_Def( itim_readrecord, 'tmm prism readrecord', status ) IF_NOTOK_RETURN(status=1) ! read spectral info allocate( ifs_sp(ifs_shn*2) ) allocate( sh_raw(ifs_shn*2,1,1) ) ifs_sp = spinf_nan ! fill with nan fu = 10 do inquire( fu, opened=opened ) if ( .not. opened ) exit fu = fu + 1 end do open( unit=fu, file="T255_info.txt", iostat=status, action='read') read(fu,*) ifs_sp close(unit=fu) sh_raw(:,1,1) = ifs_sp deallocate( ifs_sp ) allocate( spinf2d_sh_raw(ifs_shn*2,1,1) ) spinf2d_sh_raw = sh_raw call Setup( shRemap2d, sh_raw, spinf_nan, status ) ! setup remapping IF_NOTOK_RETURN(status=1) deallocate( sh_raw ) status = 0 END SUBROUTINE MFPRISM_INIT !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: MFPRISM_DONE ! ! !DESCRIPTION: !\\ !\\ ! !INTERFACE: ! SUBROUTINE MFPRISM_DONE( status ) ! ! !USES: ! use TM5_Prism, only : Done ! ! !OUTPUT PARAMETERS: ! integer, intent(out) :: status ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/mfPrism_Done' ! --- begin ----------------------------------------- call Done( shRemap2d, status ) IF_NOTOK_RETURN(status=1) call Done( shRemap3d, status ) IF_NOTOK_RETURN(status=1) if ( associated(spinf2d_sh_raw) ) deallocate( spinf2d_sh_raw ) status = 0 END SUBROUTINE MFPRISM_DONE !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: MF_INIT ! ! !DESCRIPTION: init an prism MF object !\\ !\\ ! !INTERFACE: ! SUBROUTINE MF_INIT( mf, tday, status ) ! ! !USES: ! use GO, only : TDate ! ! !OUTPUT PARAMETERS: ! type(TMeteoFile_prism), intent(out) :: mf ! ! !INPUT PARAMETERS: ! type(TDate), intent(in) :: tday integer, intent(out) :: status ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/mf_Init' ! --- begin -------------------------------- mf%tday = tday status = 0 END SUBROUTINE MF_INIT !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: MF_DONE ! ! !DESCRIPTION: !\\ !\\ ! !INTERFACE: ! SUBROUTINE MF_DONE( mf, status ) ! ! !INPUT/OUTPUT PARAMETERS: ! type(TMeteoFile_prism), intent(inout) :: mf ! ! !OUTPUT PARAMETERS: ! integer, intent(out) :: status ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/mf_Done' status = 0 end subroutine mf_Done !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: MF_READRECORD ! ! !DESCRIPTION: fill in met field with fields from OASIS3/PRISM coupler !\\ !\\ ! !INTERFACE: ! subroutine mf_ReadRecord( mf, paramkey, t1, t2, nuv, nw, & gridtype, levi, & lli, ll, sp_ll, & ggi, gg, sp_gg, & shi, sh, lnsp_sh, & tmi, status ) ! ! !USES: ! use parray, only : pa_SetShape use GO, only : TDate, wrtgol, IsAnyDate use GO, only : operator(+), operator(-), operator(/), operator(==), operator(/=) use GO, only : GO_Timer_Start, GO_Timer_End use Grid, only : TllGridInfo, TggGridInfo, TshGridInfo, TLevelInfo use Grid, only : Init, Set use tmm_info, only : TMeteoInfo, Init, AddHistory use binas, only : grav use mod_oasis use TM5_Prism, only : SetPrismTime use TM5_Prism, only : Setup, Remap use TM5_Prism, only : InqCplVar, CplVar ! ! !INPUT/OUTPUT PARAMETERS: ! type(TMeteoFile_prism), intent(inout) :: mf ! ! !INPUT PARAMETERS: ! character(len=*), intent(in) :: paramkey type(TDate), intent(in) :: t1, t2 character(len=1), intent(in) :: nuv character(len=1), intent(in) :: nw ! ! !OUTPUT PARAMETERS: ! character(len=2), intent(out) :: gridtype type(TLevelInfo), intent(out) :: levi type(TllGridInfo), intent(inout) :: lli real, pointer :: ll(:,:,:) real, pointer :: sp_ll(:,:) type(TggGridInfo), intent(inout) :: ggi real, pointer :: gg(:,:) real, pointer :: sp_gg(:) type(TshGridInfo), intent(inout) :: shi complex, pointer :: sh(:,:) complex, pointer :: lnsp_sh(:) type(TMeteoInfo), intent(out) :: tmi integer, intent(out) :: status ! ! !REMARKS: ! (1) only root arrives here, called from tmm_mf/ReadRecord ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/mf_ReadRecord' ! value filled into spinf arrays to define not a number: real, parameter :: spinf_nan = -1.2345 ! --- local ----------------------------------- type(TDate) :: tmid integer :: prism_t real(ip_realwp_p), allocatable :: ifs_ll(:,:) real(ip_realwp_p), allocatable :: ifs_sp(:) integer :: ilev integer :: k real, allocatable :: sh_raw(:,:,:) real, allocatable :: sh_zcl(:,:,:) real, allocatable :: cc_col(:) real, allocatable :: cc_rev(:) real, allocatable :: cco_col(:) real, allocatable :: ccu_rev(:) integer :: lme integer :: ivar integer :: ivar_cco, ivar_ccu integer :: info real :: tb_sec integer :: icache integer :: i,j,l character(len=256) :: error_message ! --- begin --------------------------------- call goLabel(rname) call GO_Timer_Start( itim_readrecord, status ) IF_NOTOK_RETURN(status=1) ! no times defined in t1 and t2 ? if ( IsAnyDate(t1) .and. IsAnyDate(t2) ) then ! for constant fields (orography), t1 and t2 are any date; ! use the tday stored in mf structure for the orography time: tmid = mf%tday else ! in oasis3 always begin of interval: tmid = t1 end if ! convert from tm5 time structure to prism time structure: call SetPrismTime( prism_t, tmid, status ) IF_ERROR_RETURN(status=1) !write (gol,*) trim(rname)//' '// trim(paramkey); call goPr ! *************************** READ FIELD ****************************** PARAM: SELECT CASE ( paramkey ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! 3D lat/lon fields ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! Temperature, humidity, cloud fields, convective fluxes and detrainment rates ! Cloud details: ! CLWC liquid water content (kg/kg) (halo=0) ! CIWC ice water content (kg/kg) (halo=0) ! CC cloud cover (fraction) (halo=0) case ( 'T', 'Q', 'CLWC', 'CIWC', 'CC', 'CCO','CCU', 'UDMF', 'DDMF', 'UDDR','DDDR' ) call InqCplVar( paramkey, status, ivar=ivar ) ! inquire field number of coupled field IF_NOTOK_RETURN(status=1) gridtype = 'll' ! fill lli call Get_DistGrid( dgrid( CplVar(ivar)%region ), global_lli=lli ) ! allocate arrays if necessary: call pa_SetShape( sp_ll, CplVar(ivar)%nlon, CplVar(ivar)%nlat ) call pa_SetShape( ll , CplVar(ivar)%nlon, CplVar(ivar)%nlat, CplVar(ivar)%nlev ) ! ~~ SURFACE PRESSURE ~~ ! inquire field number of coupled field: call InqCplVar( 'sp', status, ivar=ivar ) IF_NOTOK_RETURN(status=1) ! in cache ? if ( CplVar(ivar)%cache_tmid == tmid ) then sp_ll = CplVar(ivar)%cache_data(:,:,1) ! copy from cache !write (gol,'(a,i3.3)') " getting SP from CACHE, ivar=",ivar; call goPr else !write (gol,'(a,i3.3)') " getting SP from OASIS, ivar=",ivar; call goPr ilev = 1 allocate( ifs_ll(CplVar(ivar)%nlon,CplVar(ivar)%nlat) ) ! temporary storage with correct kind CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_ll, status ) SELECT CASE ( status ) CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut) CONTINUE CASE ( OASIS_OK ) TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")') CALL OASIS_ABORT( comp_id, rname, error_message ) CASE DEFAULT TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status CALL OASIS_ABORT( comp_id, rname, error_message ) END SELECT sp_ll = ifs_ll deallocate( ifs_ll ) CplVar(ivar)%cache_tmid = tmid ! store in cache CplVar(ivar)%cache_data(:,:,1) = sp_ll end if ! ~~ 3D FIELD ~~ call InqCplVar( paramkey, status, ivar=ivar ) ! inquire field number of coupled field IF_NOTOK_RETURN(status=1) !write (gol,'(a,x,a,x,a,i3.3)') " getting", trim(paramkey), "from OASIS, ivar=",ivar; call goPr ALLOCATE( ifs_ll(CplVar(ivar)%nlon,CplVar(ivar)%nlat) ) ! temporary storage with correct kind DO ilev = 1, CplVar(ivar)%nlev CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_ll, status ) SELECT CASE ( status ) CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut) CONTINUE CASE ( OASIS_OK ) TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")') CALL OASIS_ABORT( comp_id, rname, error_message ) CASE DEFAULT TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status CALL OASIS_ABORT( comp_id, rname, error_message ) END SELECT ll(:,:,CplVar(ivar)%nlev+1-ilev) = ifs_ll ! store; reverse layer order ENDDO DEALLOCATE( ifs_ll ) ! convert ... select case ( paramkey ) case ( 'Q' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] case ( 'CLWC' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] case ( 'CIWC' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] case ( 'CC' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] case ( 'CCO' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] case ( 'CCU' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] end select ! evaluate CCO / CCU select case ( paramkey ) case ( 'CCO' ) ! --- overhead cloud cover: lme = CplVar(ivar)%nlev allocate( cc_col(lme) ) allocate( cco_col(lme) ) ! !$OMP PARALLEL do j = 1, CplVar(ivar)%nlat do i = 1, CplVar(ivar)%nlon ! cf_overhead requires CC in the reversed vertical order of IFS do l = 1, lme cc_col(l) = ll(i,j,lme+1-l) enddo call cf_overhead ( lme, cc_col, cco_col ) ! cf_overhead delivers CCO at layer base in the reversed vertical order of IFS do l = 1, lme ll(i,j,l)=cco_col(lme+1-l) enddo end do end do ! !$OMP END PARALLEL deallocate( cc_col) deallocate( cco_col) case ( 'CCU' ) ! --- underfeet cloud cover: lme = CplVar(ivar)%nlev allocate( cc_rev(lme) ) allocate( ccu_rev(lme) ) ! !$OMP PARALLEL do j = 1, CplVar(ivar)%nlat do i = 1, CplVar(ivar)%nlon ! for calculating CCU cf_overhead requires CC in the vertical order of TM5 cc_rev = ll(i,j,:) call cf_overhead( lme, cc_rev, ccu_rev ) ! cf_overhead delivers CCU at layer top in the vertical order of TM5 ll(i,j,:)=ccu_rev end do end do ! !$OMP END PARALLEL deallocate( cc_rev) deallocate( ccu_rev) end select ! ~~ levels ~~ call InqCplVar( paramkey, status, ivar=ivar ) IF_NOTOK_RETURN(status=1) ! level info: field is stored in tm level order after receiving select case ( CplVar(ivar)%nlev ) case ( 19 ) call Init( levi, 'tm19', status ) IF_NOTOK_RETURN(status=1) case ( 31 ) call Init( levi, 'tm31', status ) IF_NOTOK_RETURN(status=1) case ( 34 ) call Init( levi, 'tm34', status ) IF_NOTOK_RETURN(status=1) case ( 40 ) call Init( levi, 'tm40', status ) IF_NOTOK_RETURN(status=1) case ( 60 ) call Init( levi, 'tm60', status ) IF_NOTOK_RETURN(status=1) case ( 62 ) call Init( levi, 'tm62', status ) IF_NOTOK_RETURN(status=1) case ( 91 ) call Init( levi, 'tm91', status ) IF_NOTOK_RETURN(status=1) case default write (gol,'("unsupported ifs nlev : ",i4)') CplVar(ivar)%nlev; call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end select ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! 2D surface fields ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( 'sshf', 'slhf', 'ewss', 'nsss', 'oro', 'lsm', & 'albedo', 'sr', 'ci', 'sst', 'cp', 'lsp', 'sf', & 'u10m', 'v10m', 'wspd', 'd2m', 't2m', 'ssr', 'skt', 'src', 'sd', 'swvl1', & 'tv01', 'tv02', 'tv03', 'tv04', 'tv05', 'tv06', 'tv07', 'tv09', & 'tv10', 'tv11', 'tv13', 'tv16', 'tv17', 'tv18', 'tv19', 'cvl', 'cvh' ) call InqCplVar( paramkey, status, ivar=ivar ) IF_NOTOK_RETURN(status=1) gridtype = 'll' ! intialize lat/lon info: call Get_DistGrid( dgrid( CplVar(ivar)%region ), global_lli=lli ) ! allocate arrays if necessary: call pa_SetShape( ll, CplVar(ivar)%nlon, CplVar(ivar)%nlat, 1 ) allocate( ifs_ll(CplVar(ivar)%nlon,CplVar(ivar)%nlat) ) ilev = 1 !write (gol,'(a,x,a,x,a,i3.3)') " getting", trim(paramkey), "from OASIS, ivar=",ivar; call goPr CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_ll, status ) SELECT CASE ( status ) CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut) CONTINUE CASE ( OASIS_OK ) TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")') CALL OASIS_ABORT( comp_id, rname, error_message ) CASE DEFAULT TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status CALL OASIS_ABORT( comp_id, rname, error_message ) END SELECT ll(:,:,1) = ifs_ll deallocate( ifs_ll ) ! CONVERT select case ( paramkey ) !case ( 'oro' ) ; ll = ll/grav ! m m/s2 -> m <-- oro is in m*m/s2 case ( 'lsm' ) ; ll = min( max( 0.0, ll * 100.0 ), 100.0 ) ! 0-1 -> % case ( 'albedo', 'ci', 'swvl1', 'cvl', 'cvh' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] case ( 'lsp', 'cp' ) ; ll = max( 0.0, ll / 1000.0 ) ! mm/s -> m/s ! Snow depth is received as kg/m3, ! and should be converted to height in m of water equivalent. ! The water density is here set to 1000. kg/m3. case ( 'sd', 'src' ) ; ll = max( 0.0, ll / 1000.0 ) ! mm -> m case ( 'sr', 'sf', 'ssr' ) ; ll = max( 0.0, ll) case ( 'tv01', 'tv02', 'tv03', 'tv04', 'tv05', 'tv06', 'tv07', 'tv09', & 'tv10', 'tv11', 'tv13', 'tv16', 'tv17', 'tv18', 'tv19' ) ll = min( max( 0.0, ll ), 100.0 ) ! % end select ! * level info (dummy levels) call Init( levi, 1, (/0.0,0.0/), (/1.0,0.0/), status ) IF_NOTOK_RETURN(status=1) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! 2D spectral fields ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( 'LNSP' ) call InqCplVar( 'spinf2d', status, ivar=ivar ) IF_NOTOK_RETURN(status=1) gridtype = 'sh' ! intialize spherical harmonic field info: call Init( shi, CplVar(ivar)%shT, status ) IF_NOTOK_RETURN(status=1) ! allocate array if necessary: call pa_SetShape( sh, CplVar(ivar)%shn, 1 ) ! raw spectral field from coupler: allocate( sh_raw(CplVar(ivar)%shn_recv*2,1,1) ) allocate( sh_zcl(2,CplVar(ivar)%shn,1) ) ! * SPINF2D ! setup remapping if not done yet if ( shRemap2d%t /= tmid ) then ! receive info field every time step call InqCplVar( 'spinf2d', status, ivar=ivar ) IF_NOTOK_RETURN(status=1) allocate( ifs_sp(CplVar(ivar)%shn_recv*2) ) ifs_sp = spinf_nan ! fill with nan ilev = 1 !write (gol,'(a,i3.3)') " getting SPINF2D from OASIS, ivar=",ivar; call goPr call OASIS_Get( CplVar(ivar)%var_id(ilev), prism_t, ifs_sp, status ) SELECT CASE ( status ) CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut) CONTINUE CASE ( OASIS_OK ) TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")') CALL OASIS_ABORT( comp_id, rname, error_message ) CASE DEFAULT TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status CALL OASIS_ABORT( comp_id, rname, error_message ) END SELECT sh_raw(:,1,1) = ifs_sp deallocate( ifs_sp ) if ( .not. associated(spinf2d_sh_raw) ) allocate( spinf2d_sh_raw(CplVar(ivar)%shn_recv*2,1,1) ) spinf2d_sh_raw = sh_raw call Setup( shRemap2d, sh_raw, spinf_nan, status ) ! setup remapping IF_NOTOK_RETURN(status=1) shRemap2d%t = tmid ! store time end if ! * LNSP call InqCplVar( 'LNSP', status, ivar=ivar ) IF_NOTOK_RETURN(status=1) if ( CplVar(ivar)%cache_tmid == tmid ) then ! in cache? sh_zcl = CplVar(ivar)%cache_data !write (gol,'(a,i3.3)') " getting LNSP from CACHE, ivar=",ivar; call goPr else allocate( ifs_sp(CplVar(ivar)%shn_recv*2) ) ifs_sp = spinf_nan ilev = 1 !write (gol,'(a,i3.3)') " getting LNSP from OASIS, ivar=",ivar; call goPr call OASIS_Get( CplVar(ivar)%var_id(ilev), prism_t, ifs_sp, status ) SELECT CASE ( status ) CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut) CONTINUE CASE ( OASIS_OK ) TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")') CALL OASIS_ABORT( comp_id, rname, error_message ) CASE DEFAULT TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status CALL OASIS_ABORT( comp_id, rname, error_message ) END SELECT sh_raw(:,1,1) = ifs_sp deallocate( ifs_sp ) call Remap( shRemap2d, sh_raw, shi, sh_zcl, status ) IF_NOTOK_RETURN(status=1) CplVar(ivar)%cache_tmid = tmid CplVar(ivar)%cache_data = sh_zcl end if sh = cmplx(sh_zcl(1,:,:),sh_zcl(2,:,:)) ! convert to complex deallocate( sh_raw ) deallocate( sh_zcl ) ! * level info (dummy levels) call Init( levi, 1, (/0.0,0.0/), (/1.0,0.0/), status ) IF_NOTOK_RETURN(status=1) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! 3D spectral fields ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( 'VO', 'D' ) call InqCplVar( paramkey, status, ivar=ivar ) IF_NOTOK_RETURN(status=1) gridtype = 'sh' ! intialize spherical harmonic field info: call Init( shi, CplVar(ivar)%shT, status ) IF_NOTOK_RETURN(status=1) ! allocate arrays if necessary: call pa_SetShape( sh , CplVar(ivar)%shn, CplVar(ivar)%nlev ) call pa_SetShape( lnsp_sh, CplVar(ivar)%shn ) ! raw spectral field from coupler: allocate( sh_raw(CplVar(ivar)%shn_recv*2,CplVar(ivar)%nlev,1) ) allocate( sh_zcl(2,CplVar(ivar)%shn,CplVar(ivar)%nlev) ) ! * SPINF3D ! setup remapping if not done yet if ( shRemap3d%t /= tmid ) then sh_raw = spinf_nan ! use save field: do ilev = 1, CplVar(ivar)%nlev do k = 1, CplVar(ivar)%shn_recv*2 if ( spinf2d_sh_raw(k,1,1) /= spinf_nan ) then sh_raw(k,ilev,1) = spinf2d_sh_raw(k,1,1) + sign(ilev*0.01,spinf2d_sh_raw(k,1,1)) end if end do end do call Setup( shRemap3d, sh_raw, spinf_nan, status ) IF_NOTOK_RETURN(status=1) shRemap3d%t = tmid end if ! * 3D SPECTRAL FIELD call InqCplVar( paramkey, status, ivar=ivar ) IF_NOTOK_RETURN(status=1) if ( CplVar(ivar)%cache_tmid == tmid ) then ! in cache ? sh_zcl = CplVar(ivar)%cache_data !write (gol,'(a,x,a,x,a,i3.3)') " getting", trim(paramkey), "from CACHE, ivar=",ivar; call goPr else allocate( ifs_sp(CplVar(ivar)%shn_recv*2) ) ifs_sp = spinf_nan !write (gol,'(a,x,a,x,a,i3.3)') " getting", trim(paramkey), "from OASIS, ivar=",ivar; call goPr do ilev = 1, CplVar(ivar)%nlev CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_sp, status ) SELECT CASE ( status ) CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut) CONTINUE CASE ( OASIS_OK ) TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")') CALL OASIS_ABORT( comp_id, rname, error_message ) CASE DEFAULT TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status CALL OASIS_ABORT( comp_id, rname, error_message ) END SELECT sh_raw(:,ilev,1) = ifs_sp end do deallocate( ifs_sp ) call Remap( shRemap3d, sh_raw, shi, sh_zcl, status ) IF_NOTOK_RETURN(status=1) CplVar(ivar)%cache_tmid = tmid CplVar(ivar)%cache_data = sh_zcl end if ! convert to complex: sh = cmplx(sh_zcl(1,:,:),sh_zcl(2,:,:)) ! * LNSP call InqCplVar( 'LNSP', status, ivar=ivar ) IF_NOTOK_RETURN(status=1) ! copy from cache: lnsp_sh = cmplx(CplVar(ivar)%cache_data(1,:,1),CplVar(ivar)%cache_data(2,:,1)) deallocate( sh_raw ) deallocate( sh_zcl ) ! * level info call InqCplVar( paramkey, status, ivar=ivar ) IF_NOTOK_RETURN(status=1) ! gridless fields are received in original ec order! select case ( CplVar(ivar)%nlev ) case ( 19 ) call Init( levi, 'ec19', status ) IF_NOTOK_RETURN(status=1) case ( 31 ) call Init( levi, 'ec31', status ) IF_NOTOK_RETURN(status=1) case ( 34 ) call Init( levi, 'ec34', status ) IF_NOTOK_RETURN(status=1) case ( 40 ) call Init( levi, 'ec40', status ) IF_NOTOK_RETURN(status=1) case ( 60 ) call Init( levi, 'ec60', status ) IF_NOTOK_RETURN(status=1) case ( 62 ) call Init( levi, 'ec62', status ) IF_NOTOK_RETURN(status=1) case ( 91 ) call Init( levi, 'ec91', status ) IF_NOTOK_RETURN(status=1) case default write (gol,'("unsupported ifs nlev : ",i4)') CplVar(ivar)%nlev; call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end select case default write (gol,'("unsupported paramkey `",a,"`")') trim(paramkey); call goErr write (gol,'("in ",a)') rname; status=1; return; call goErr END SELECT PARAM ! fill some info values call Init( tmi, paramkey, 'unkown', status ) call AddHistory( tmi, 'model==oasis_coupler', status ) call GO_Timer_End( itim_readrecord, status ) IF_NOTOK_RETURN(status=1) call goLabel() status = 0 end subroutine mf_ReadRecord !EOC subroutine mf_ReadRecord_parallel( mf, paramkey, t1, t2, nuv, nw, & gridtype, levi, & lli, ll, sp_ll, & ggi, gg, sp_gg, & shi, sh, lnsp_sh, & tmi, status ) ! ! !USES: ! use parray, only : pa_SetShape use GO, only : TDate, wrtgol, IsAnyDate use GO, only : operator(+), operator(-), operator(/), operator(==), operator(/=) use GO, only : GO_Timer_Start, GO_Timer_End use Grid, only : TllGridInfo, TggGridInfo, TshGridInfo, TLevelInfo use Grid, only : Init, Set use tmm_info, only : TMeteoInfo, Init, AddHistory use binas, only : grav use mod_oasis use TM5_Prism, only : SetPrismTime use TM5_Prism, only : Setup, Remap use TM5_Prism, only : InqCplVar, CplVar, ifs_shT, ifs_shn ! ! !INPUT/OUTPUT PARAMETERS: ! type(TMeteoFile_prism), intent(inout) :: mf ! ! !INPUT PARAMETERS: ! character(len=*), intent(in) :: paramkey type(TDate), intent(in) :: t1, t2 character(len=1), intent(in) :: nuv character(len=1), intent(in) :: nw ! ! !OUTPUT PARAMETERS: ! character(len=2), intent(out) :: gridtype type(TLevelInfo), intent(out) :: levi type(TllGridInfo), intent(inout) :: lli real, pointer :: ll(:,:,:) real, pointer :: sp_ll(:,:) type(TggGridInfo), intent(inout) :: ggi real, pointer :: gg(:,:) real, pointer :: sp_gg(:) type(TshGridInfo), intent(inout) :: shi complex, pointer :: sh(:,:) complex, pointer :: lnsp_sh(:) type(TMeteoInfo), intent(out) :: tmi integer, intent(out) :: status ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/mf_ReadRecord_parallel' ! value filled into spinf arrays to define not a number: real, parameter :: spinf_nan = -1.2345 ! --- local ----------------------------------- type(TDate) :: tmid integer :: prism_t real(ip_realwp_p), allocatable :: ifs_ll(:,:) real(ip_realwp_p), allocatable :: ifs_sp(:) integer :: ilev integer :: k real, allocatable :: sh_raw(:,:,:) real, allocatable :: sh_zcl(:,:,:) real, allocatable :: cc_col(:) real, allocatable :: cc_rev(:) real, allocatable :: cco_col(:) real, allocatable :: ccu_rev(:) integer :: lme integer :: ivar integer :: ivar_cco, ivar_ccu integer :: info real :: tb_sec integer :: icache integer :: i,j,l character(len=256) :: error_message ! --- begin --------------------------------- call goLabel(rname) call GO_Timer_Start( itim_readrecord, status ) IF_NOTOK_RETURN(status=1) ! no times defined in t1 and t2 ? if ( IsAnyDate(t1) .and. IsAnyDate(t2) ) then ! for constant fields (orography), t1 and t2 are any date; ! use the tday stored in mf structure for the orography time: tmid = mf%tday else ! in oasis3 always begin of interval: tmid = t1 end if ! convert from tm5 time structure to prism time structure: call SetPrismTime( prism_t, tmid, status ) IF_ERROR_RETURN(status=1) ! *************************** READ FIELD ****************************** PARAM: SELECT CASE ( paramkey ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! 3D lat/lon fields ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! Temperature, humidity, cloud fields, convective fluxes and detrainment rates ! Cloud details: ! CLWC liquid water content (kg/kg) (halo=0) ! CIWC ice water content (kg/kg) (halo=0) ! CC cloud cover (fraction) (halo=0) case ( 'T', 'Q', 'CLWC', 'CIWC', 'CC', 'CCO','CCU', 'UDMF', 'DDMF', 'UDDR','DDDR' ) call InqCplVar( paramkey, status, ivar=ivar ) ! inquire field number of coupled field IF_NOTOK_RETURN(status=1) gridtype = 'll' ! intialize lat/lon info: call Get_DistGrid( dgrid( CplVar(ivar)%region ), lli=lli ) ! allocate arrays if necessary: call pa_SetShape( sp_ll, CplVar(ivar)%nlon, CplVar(ivar)%nlat ) call pa_SetShape( ll , CplVar(ivar)%nlon, CplVar(ivar)%nlat, CplVar(ivar)%nlev ) ! ~~ SURFACE PRESSURE ~~ ! inquire field number of coupled field: call InqCplVar( 'sp', status, ivar=ivar ) IF_NOTOK_RETURN(status=1) ! in cache ? if ( CplVar(ivar)%cache_tmid == tmid ) then sp_ll = CplVar(ivar)%cache_data(:,:,1) ! copy from cache else ! Are we really ever getting here???? Looks like SP is computed from LNSP ilev = 1 allocate( ifs_ll(CplVar(ivar)%nlon,CplVar(ivar)%nlat) ) ! temporary storage with correct kind CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_ll, status ) SELECT CASE ( status ) CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut) CONTINUE CASE ( OASIS_OK ) TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")') CALL OASIS_ABORT( comp_id, rname, error_message ) CASE DEFAULT TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status CALL OASIS_ABORT( comp_id, rname, error_message ) END SELECT sp_ll = ifs_ll deallocate( ifs_ll ) CplVar(ivar)%cache_tmid = tmid ! store in cache CplVar(ivar)%cache_data(:,:,1) = sp_ll end if ! ~~ 3D FIELD ~~ call InqCplVar( paramkey, status, ivar=ivar ) ! inquire field number of coupled field IF_NOTOK_RETURN(status=1) ALLOCATE( ifs_ll(CplVar(ivar)%nlon,CplVar(ivar)%nlat) ) ! temporary storage with correct kind DO ilev = 1, CplVar(ivar)%nlev CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_ll, status ) SELECT CASE ( status ) CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut) CONTINUE CASE ( OASIS_OK ) TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")') CALL OASIS_ABORT( comp_id, rname, error_message ) CASE DEFAULT TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status CALL OASIS_ABORT( comp_id, rname, error_message ) END SELECT ll(:,:,CplVar(ivar)%nlev+1-ilev) = ifs_ll ! store; reverse layer order ENDDO DEALLOCATE( ifs_ll ) ! convert ... select case ( paramkey ) case ( 'Q' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] case ( 'CLWC' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] case ( 'CIWC' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] case ( 'CC' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] case ( 'CCO' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] case ( 'CCU' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] end select ! evaluate CCO / CCU select case ( paramkey ) case ( 'CCO' ) ! --- overhead cloud cover: lme = CplVar(ivar)%nlev allocate( cc_col(lme) ) allocate( cco_col(lme) ) ! !$OMP PARALLEL do j = 1, CplVar(ivar)%nlat do i = 1, CplVar(ivar)%nlon ! cf_overhead requires CC in the reversed vertical order of IFS do l = 1, lme cc_col(l) = ll(i,j,lme+1-l) enddo call cf_overhead ( lme, cc_col, cco_col ) ! cf_overhead delivers CCO at layer base in the reversed vertical order of IFS do l = 1, lme ll(i,j,l)=cco_col(lme+1-l) enddo end do end do ! !$OMP END PARALLEL deallocate( cc_col) deallocate( cco_col) case ( 'CCU' ) ! --- underfeet cloud cover: lme = CplVar(ivar)%nlev allocate( cc_rev(lme) ) allocate( ccu_rev(lme) ) ! !$OMP PARALLEL do j = 1, CplVar(ivar)%nlat do i = 1, CplVar(ivar)%nlon ! for calculating CCU cf_overhead requires CC in the vertical order of TM5 cc_rev = ll(i,j,:) call cf_overhead( lme, cc_rev, ccu_rev ) ! cf_overhead delivers CCU at layer top in the vertical order of TM5 ll(i,j,:)=ccu_rev end do end do ! !$OMP END PARALLEL deallocate( cc_rev) deallocate( ccu_rev) end select ! ~~ levels ~~ call InqCplVar( paramkey, status, ivar=ivar ) IF_NOTOK_RETURN(status=1) ! level info: field is stored in tm level order after receiving select case ( CplVar(ivar)%nlev ) case ( 4 ) call Init( levi, 'tm4', status ) IF_NOTOK_RETURN(status=1) case ( 10 ) call Init( levi, 'tm10', status ) IF_NOTOK_RETURN(status=1) case ( 19 ) call Init( levi, 'tm19', status ) IF_NOTOK_RETURN(status=1) case ( 31 ) call Init( levi, 'tm31', status ) IF_NOTOK_RETURN(status=1) case ( 34 ) call Init( levi, 'tm34', status ) IF_NOTOK_RETURN(status=1) case ( 40 ) call Init( levi, 'tm40', status ) IF_NOTOK_RETURN(status=1) case ( 60 ) call Init( levi, 'tm60', status ) IF_NOTOK_RETURN(status=1) case ( 62 ) call Init( levi, 'tm62', status ) IF_NOTOK_RETURN(status=1) case ( 91 ) call Init( levi, 'tm91', status ) IF_NOTOK_RETURN(status=1) case default write (gol,'("unsupported ifs nlev : ",i4)') CplVar(ivar)%nlev; call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end select ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! 2D surface fields ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( 'sshf', 'slhf', 'ewss', 'nsss', 'oro', 'lsm', & 'albedo', 'sr', 'ci', 'sst', 'cp', 'lsp', 'sf', & 'u10m', 'v10m', 'wspd', 'd2m', 't2m', 'ssr', 'skt', 'src', 'sd', 'swvl1', & 'tv01', 'tv02', 'tv03', 'tv04', 'tv05', 'tv06', 'tv07', 'tv09', & 'tv10', 'tv11', 'tv13', 'tv16', 'tv17', 'tv18', 'tv19', 'cvl', 'cvh' ) call InqCplVar( paramkey, status, ivar=ivar ) IF_NOTOK_RETURN(status=1) gridtype = 'll' ! intialize lat/lon info: call Get_DistGrid( dgrid( CplVar(ivar)%region ), lli=lli ) ! allocate arrays if necessary: call pa_SetShape( ll, CplVar(ivar)%nlon, CplVar(ivar)%nlat, 1 ) allocate( ifs_ll(CplVar(ivar)%nlon,CplVar(ivar)%nlat) ) ilev = 1 CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_ll, status ) SELECT CASE ( status ) CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut) CONTINUE CASE ( OASIS_OK ) TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")') CALL OASIS_ABORT( comp_id, rname, error_message ) CASE DEFAULT TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status CALL OASIS_ABORT( comp_id, rname, error_message ) END SELECT ll(:,:,1) = ifs_ll deallocate( ifs_ll ) ! CONVERT select case ( paramkey ) !case ( 'oro' ) ; ll = ll/grav ! m m/s2 -> m <-- oro is in m*m/s2 case ( 'lsm' ) ; ll = min( max( 0.0, ll * 100.0 ), 100.0 ) ! 0-1 -> % case ( 'albedo', 'ci', 'swvl1', 'cvl', 'cvh' ) ; ll = min( max( 0.0, ll ), 1.0 ) ! [0-1] case ( 'lsp', 'cp' ) ; ll = max( 0.0, ll / 1000.0 ) ! mm/s -> m/s ! Snow depth is received as kg/m3, ! and should be converted to height in m of water equivalent. ! The water density is here set to 1000. kg/m3. case ( 'sd', 'src' ) ; ll = max( 0.0, ll / 1000.0 ) ! mm -> m case ( 'sr', 'sf', 'ssr' ) ; ll = max( 0.0, ll) case ( 'tv01', 'tv02', 'tv03', 'tv04', 'tv05', 'tv06', 'tv07', 'tv09', & 'tv10', 'tv11', 'tv13', 'tv16', 'tv17', 'tv18', 'tv19' ) ll = min( max( 0.0, ll ), 100.0 ) ! % end select ! * level info (dummy levels) call Init( levi, 1, (/0.0,0.0/), (/1.0,0.0/), status ) IF_NOTOK_RETURN(status=1) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! 2D spectral fields ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( 'LNSP' ) gridtype = 'sh' ! intialize spherical harmonic field info: call Init( shi, ifs_shT, status ) IF_NOTOK_RETURN(status=1) ! allocate array if necessary: call pa_SetShape( sh, ifs_shn, 1 ) ! raw spectral field from coupler allocate( sh_raw(ifs_shn*2,1,1) ) allocate( sh_zcl(2,ifs_shn,1) ) ! store time if ( shRemap2d%t /= tmid ) then shRemap2d%t = tmid end if ! * LNSP call InqCplVar( 'LNSP', status, ivar=ivar ) IF_NOTOK_RETURN(status=1) if ( CplVar(ivar)%cache_tmid == tmid ) then ! in cache? sh_zcl = CplVar(ivar)%cache_data else allocate( ifs_sp(CplVar(ivar)%shn_recv*2) ) ifs_sp = spinf_nan ilev = 1 call OASIS_Get( CplVar(ivar)%var_id(ilev), prism_t, ifs_sp, status ) SELECT CASE ( status ) CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut) CONTINUE CASE ( OASIS_OK ) TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")') CALL OASIS_ABORT( comp_id, rname, error_message ) CASE DEFAULT TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status CALL OASIS_ABORT( comp_id, rname, error_message ) END SELECT sh_raw(:,1,1) = ifs_sp deallocate( ifs_sp ) call Remap( shRemap2d, sh_raw, shi, sh_zcl, status ) IF_NOTOK_RETURN(status=1) CplVar(ivar)%cache_tmid = tmid CplVar(ivar)%cache_data = sh_zcl end if sh = cmplx(sh_zcl(1,:,:),sh_zcl(2,:,:)) ! convert to complex deallocate( sh_raw ) deallocate( sh_zcl ) ! * level info (dummy levels) call Init( levi, 1, (/0.0,0.0/), (/1.0,0.0/), status ) IF_NOTOK_RETURN(status=1) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! 3D spectral fields ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( 'VO', 'D' ) call InqCplVar( paramkey, status, ivar=ivar ) IF_NOTOK_RETURN(status=1) gridtype = 'sh' ! intialize spherical harmonic field info: call Init( shi, CplVar(ivar)%shT, status ) IF_NOTOK_RETURN(status=1) ! allocate arrays if necessary: call pa_SetShape( sh , CplVar(ivar)%shn, CplVar(ivar)%nlev ) call pa_SetShape( lnsp_sh, CplVar(ivar)%shn ) ! raw spectral field from coupler: allocate( sh_raw(CplVar(ivar)%shn_recv*2,CplVar(ivar)%nlev,1) ) allocate( sh_zcl(2,CplVar(ivar)%shn,CplVar(ivar)%nlev) ) ! * SPINF3D ! setup remapping if not done yet if ( shRemap3d%t /= tmid ) then sh_raw = spinf_nan ! use save field: do ilev = 1, CplVar(ivar)%nlev do k = 1, CplVar(ivar)%shn_recv*2 if ( spinf2d_sh_raw(k,1,1) /= spinf_nan ) then sh_raw(k,ilev,1) = spinf2d_sh_raw(k,1,1) + sign(ilev*0.01,spinf2d_sh_raw(k,1,1)) end if end do end do call Setup( shRemap3d, sh_raw, spinf_nan, status ) IF_NOTOK_RETURN(status=1) shRemap3d%t = tmid end if ! * 3D SPECTRAL FIELD call InqCplVar( paramkey, status, ivar=ivar ) IF_NOTOK_RETURN(status=1) if ( CplVar(ivar)%cache_tmid == tmid ) then ! in cache ? sh_zcl = CplVar(ivar)%cache_data else allocate( ifs_sp(CplVar(ivar)%shn_recv*2) ) ifs_sp = spinf_nan do ilev = 1, CplVar(ivar)%nlev CALL OASIS_GET( CplVar(ivar)%var_id(ilev), prism_t, ifs_sp, status ) SELECT CASE ( status ) CASE (OASIS_Recvd, OASIS_FromRest, OASIS_Input, OASIS_RecvOut, OASIS_FromRestOut) CONTINUE CASE ( OASIS_OK ) TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: no exchange, while expected!")') CALL OASIS_ABORT( comp_id, rname, error_message ) CASE DEFAULT TRACEBACK WRITE (error_message,'("TMM_MF_PRISM: Error in OASIS_GET:",i6)') status CALL OASIS_ABORT( comp_id, rname, error_message ) END SELECT sh_raw(:,ilev,1) = ifs_sp end do deallocate( ifs_sp ) call Remap( shRemap3d, sh_raw, shi, sh_zcl, status ) IF_NOTOK_RETURN(status=1) CplVar(ivar)%cache_tmid = tmid CplVar(ivar)%cache_data = sh_zcl end if ! convert to complex: sh = cmplx(sh_zcl(1,:,:),sh_zcl(2,:,:)) ! * LNSP call InqCplVar( 'LNSP', status, ivar=ivar ) IF_NOTOK_RETURN(status=1) ! copy from cache: lnsp_sh = cmplx(CplVar(ivar)%cache_data(1,:,1),CplVar(ivar)%cache_data(2,:,1)) deallocate( sh_raw ) deallocate( sh_zcl ) ! * level info call InqCplVar( paramkey, status, ivar=ivar ) IF_NOTOK_RETURN(status=1) ! gridless fields are received in original ec order! select case ( CplVar(ivar)%nlev ) case ( 4 ) call Init( levi, 'ec4', status ) IF_NOTOK_RETURN(status=1) case ( 10 ) call Init( levi, 'ec10', status ) IF_NOTOK_RETURN(status=1) case ( 19 ) call Init( levi, 'ec19', status ) IF_NOTOK_RETURN(status=1) case ( 31 ) call Init( levi, 'ec31', status ) IF_NOTOK_RETURN(status=1) case ( 34 ) call Init( levi, 'ec34', status ) IF_NOTOK_RETURN(status=1) case ( 40 ) call Init( levi, 'ec40', status ) IF_NOTOK_RETURN(status=1) case ( 60 ) call Init( levi, 'ec60', status ) IF_NOTOK_RETURN(status=1) case ( 62 ) call Init( levi, 'ec62', status ) IF_NOTOK_RETURN(status=1) case ( 91 ) call Init( levi, 'ec91', status ) IF_NOTOK_RETURN(status=1) case default write (gol,'("unsupported ifs nlev : ",i4)') CplVar(ivar)%nlev; call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end select case default write (gol,'("unsupported paramkey `",a,"`")') trim(paramkey); call goErr write (gol,'("in ",a)') rname; status=1; return; call goErr END SELECT PARAM ! fill some info values call Init( tmi, paramkey, 'unkown', status ) call AddHistory( tmi, 'model==oasis_coupler', status ) call GO_Timer_End( itim_readrecord, status ) IF_NOTOK_RETURN(status=1) call goLabel() status = 0 end subroutine mf_ReadRecord_parallel !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: CF_OVERHEAD ! ! !DESCRIPTION: ! ! Calculate total cloud fraction overhead the base of each layer ! based on random/maximum overlap assumptions ! Based on code provided by Rob van Dorland ! ! Input: ! nlev : number of vertical levels ! yclfr : cloud fraction (cc) per cell (0-1) ! ! Output: ! wccro: overhead cloud fraction ! ! Optional arguments: ! scheme='ecmwf' : 'ecmwf' -> iovln=1 ! 'other' -> iovln=0 ! eps=1.0e-4 : cltres ! ! Parameters: ! iovln : switch ! 1 = ecmwf (maximum random overlap assumption) scheme ! 0 = another scheme ! cltres : threshold (minimum) cloud fraction used ! for numerical stability (division by zero ! and to eliminate small unrealistic cloud fractions ! ! Notes: ! - Index=1 of arrays (yclfr) corresponds to model top ! - The clouds are supposed to be distributed homogeneously ! in the vertical in each layer. ! !\\ !\\ ! !INTERFACE: ! SUBROUTINE CF_OVERHEAD( nlev, yclfr, wccro, scheme, eps ) ! ! !INPUT PARAMETERS: ! integer, intent(in) :: nlev real, intent(in) :: yclfr(nlev) ! ! !OUTPUT PARAMETERS: ! real, intent(out) :: wccro(nlev) ! ! !OPTIONAL INPUT PARAMETERS: ! character(len=*), intent(in), optional :: scheme real, intent(in), optional :: eps ! ! !REVISION HISTORY: ! Peter van Velthoven - 22 nov 2002 ! Arjo Segers - 25 nov 2002 - Optional arguments ! Vincent Huijnen - 27 may 2002 - Applied in TM5-IFS coupled code ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ !BOC real :: clfr0, clfr1, clfr2, ctver real :: zclear, zcloud integer :: jk ! --- settings ----------------------------- integer :: iovln = 1 ! ecmwf; maximum random overlap real :: cltres = 1.0e-4 ! --- begin ----------------------------- if ( present(scheme) ) then select case ( scheme ) case ( 'ecmwf' ) iovln = 1 case ( 'other' ) iovln = 0 case default print *, 'Unsupported scheme "'//scheme//'".' stop 'FATAL BUG IN cf_overhead' end select end if if ( present(eps) ) cltres = eps select case ( iovln ) case ( 0 ) !----------------------------------------- ! scheme 0: maximum overlap unless there's a ! clear sky layer in between? !----------------------------------------- clfr0 = 0.0 clfr2 = 0.0 ctver = 1.0 do jk = 1, nlev clfr1 = yclfr(jk) if ( clfr1 < cltres ) then !---------------- ! random overlap !---------------- ctver = ctver * ( 1.0 - clfr2 ) clfr2 = 0.0 else if ( clfr0 < cltres ) then clfr2 = clfr1 else !---------------- ! maximum overlap !---------------- clfr2 = max( clfr1,clfr2 ) end if end if clfr0 = clfr1 wccro(jk) = 1.0 - ctver * ( 1.0 - clfr2 ) end do !ctver=ctver*(1.-clfr2) !wccro=1.-ctver case ( 1 ) !----------------------------------------- ! ecmwf scheme !----------------------------------------- zclear = 1.0 zcloud = 0.0 do jk = 1, nlev zclear = zclear*(1.0-max(yclfr(jk),zcloud))/(1.0-min(zcloud,1.0-cltres)) zcloud = yclfr(jk) wccro(jk) = 1.0 - zclear end do case default print *, 'unknown switch',IOVLN stop 'FATAL BUG IN cf_overhead' end select END SUBROUTINE CF_OVERHEAD !EOC END MODULE TMM_MF_PRISM