SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/SURFEX/put

Go to the documentation of this file.
00001 !     #########
00002       SUBROUTINE PUT_SFXCPL_n(HPROGRAM,KI,KSW,PZENITH,PSW_BANDS,PTSRAD,     &
00003                                 PEMIS,PDIR_ALB,PSCA_ALB,PICE,PSST,PALB_SEAICE,&
00004                                 PUMER,PVMER,PTICE)  
00005 !     #################################################################################################
00006 !
00007 !!****  *PUT_SFXCPL_n* - routine to modify some variables in surfex from information coming
00008 !                        from an ocean and/or a river routing model (but already on Surfex grid)
00009 !                        Direct and diffuse total albedo are initialysed to GELATO sea-ice albedo
00010 !!    PURPOSE
00011 !!    -------
00012 !!
00013 !!**  METHOD
00014 !!    ------
00015 !!
00016 !!    EXTERNAL
00017 !!    --------
00018 !!
00019 !!
00020 !!    IMPLICIT ARGUMENTS
00021 !!    ------------------
00022 !!
00023 !!    REFERENCE
00024 !!    ---------
00025 !!
00026 !!
00027 !!    AUTHOR
00028 !!    ------
00029 !!      B. Decharme      *Meteo France* 
00030 !!
00031 !!    MODIFICATIONS
00032 !!    -------------
00033 !!      Original    08/2009
00034 !-------------------------------------------------------------------------------
00035 !
00036 !*       0.    DECLARATIONS
00037 !              ------------
00038 !
00039 USE MODD_CSTS,       ONLY : XTT, XTTS, XICEC
00040 !
00041 USE MODD_SEAFLUX_n,  ONLY : XUMER, XVMER
00042 !                            
00043 USE MODI_PACK_SAME_RANK
00044 USE MODI_GET_LUOUT
00045 !
00046 !
00047 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00048 USE PARKIND1  ,ONLY : JPRB
00049 !
00050 USE MODI_ABOR1_SFX
00051 !
00052 USE MODI_GET_1D_MASK
00053 !
00054 USE MODI_PUT_RAD_SEA_n
00055 !
00056 USE MODI_PUT_RAD_WAT_n
00057 !
00058 USE MODI_UPDATE_ESM_SURF_ATM_n
00059 !
00060 USE MODI_GET_FRAC_n
00061 IMPLICIT NONE
00062 !
00063 !*       0.1   Declarations of arguments
00064 !              -------------------------
00065 !
00066  CHARACTER(LEN=6),        INTENT(IN)  :: HPROGRAM
00067 INTEGER,                 INTENT(IN)  :: KI      ! number of points
00068 INTEGER,                 INTENT(IN)  :: KSW     ! number of bands
00069 !
00070 REAL, DIMENSION(KI),      INTENT(IN) :: PZENITH
00071 REAL, DIMENSION(KSW),     INTENT(IN) :: PSW_BANDS ! mean wavelength of each shortwave band (m)
00072 !
00073 REAL, DIMENSION(KI),     INTENT(OUT) :: PTSRAD   ! Total radiative temperature see by the atmosphere
00074 REAL, DIMENSION(KI),     INTENT(OUT) :: PEMIS    ! Total emissivity see by the atmosphere
00075 REAL, DIMENSION(KI,KSW), INTENT(OUT) :: PDIR_ALB ! Total direct albedo see by the atmosphere
00076 REAL, DIMENSION(KI,KSW), INTENT(OUT) :: PSCA_ALB ! Total diffus albedo see by the atmosphere
00077 !
00078 REAL, DIMENSION(KI),     INTENT(IN   ), OPTIONAL :: PICE        ! Sea/Ice fraction
00079 REAL, DIMENSION(KI),     INTENT(INOUT), OPTIONAL :: PSST        ! SST
00080 REAL, DIMENSION(KI),     INTENT(INOUT), OPTIONAL :: PALB_SEAICE ! Sea_ice albedo
00081 REAL, DIMENSION(KI),     INTENT(IN   ), OPTIONAL :: PUMER       ! U sea current
00082 REAL, DIMENSION(KI),     INTENT(IN   ), OPTIONAL :: PVMER       ! V sea current
00083 REAL, DIMENSION(KI),     INTENT(IN   ), OPTIONAL :: PTICE       ! Sea ice temperature
00084 !
00085 !
00086 !*       0.2   Declarations of local variables
00087 !              -------------------------------
00088 !
00089 REAL, DIMENSION(KI) :: ZSEA    ! fraction of sea
00090 REAL, DIMENSION(KI) :: ZWATER  ! fraction of water
00091 REAL, DIMENSION(KI) :: ZNATURE ! fraction of nature
00092 REAL, DIMENSION(KI) :: ZTOWN   ! fraction of town
00093 !
00094 INTEGER :: ILU, ILUOUT
00095 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00096 !
00097 !-------------------------------------------------------------------------------
00098 IF (LHOOK) CALL DR_HOOK('PUT_SFXCPL_N',0,ZHOOK_HANDLE)
00099  CALL GET_LUOUT(HPROGRAM,ILUOUT)
00100 !-------------------------------------------------------------------------------
00101 !
00102 ! Global argument
00103 !
00104  CALL GET_FRAC_n(HPROGRAM, KI, ZSEA, ZWATER, ZNATURE, ZTOWN)
00105 !
00106 !-------------------------------------------------------------------------------
00107 ! Put variable over sea tile
00108 !
00109 IF(PRESENT(PICE).AND.PRESENT(PSST).AND.PRESENT(PTICE).AND.PRESENT(PALB_SEAICE).AND.PRESENT(PUMER).AND.PRESENT(PVMER))THEN
00110 !
00111   ILU=COUNT(ZSEA(:)>0.0)
00112 !  
00113   IF(ILU>0) CALL TREAT_SURF(ILU,'S')
00114 !
00115 ENDIF
00116 !
00117 !-------------------------------------------------------------------------------
00118 ! Put variable over water tile
00119 !
00120 IF(PRESENT(PICE).AND.PRESENT(PSST).AND.PRESENT(PTICE).AND.PRESENT(PALB_SEAICE))THEN
00121 !
00122   ILU=COUNT(ZWATER(:)>0.0)
00123 !  
00124   IF(ILU>0) CALL TREAT_SURF(ILU,'W')
00125 !  
00126 ENDIF
00127 !
00128 !-------------------------------------------------------------------------------
00129 ! Update radiative properties at time t+1 for radiative scheme
00130 !-------------------------------------------------------------------------------
00131 !
00132  CALL UPDATE_ESM_SURF_ATM_n(HPROGRAM,KI,KSW,PZENITH,PSW_BANDS,PTSRAD,PDIR_ALB,PSCA_ALB,PEMIS)
00133 !
00134 !-------------------------------------------------------------------------------
00135 !
00136 IF (LHOOK) CALL DR_HOOK('PUT_SFXCPL_N',1,ZHOOK_HANDLE)
00137 !
00138 CONTAINS
00139 !
00140 SUBROUTINE TREAT_SURF(KLU,YTYPE)
00141 !
00142 IMPLICIT NONE
00143 !
00144 INTEGER, INTENT(IN) :: KLU
00145  CHARACTER(LEN=1), INTENT(IN) :: YTYPE
00146 !
00147 INTEGER, DIMENSION(KLU) :: IMASK   ! Working mask
00148 REAL,    DIMENSION(KLU) :: ZICE     ! ice fraction from GELATO
00149 REAL,    DIMENSION(KLU) :: ZTS      ! total SST (+ice)
00150 REAL,    DIMENSION(KLU) :: ZTICE    ! Sea-ice temperature
00151 REAL,    DIMENSION(KLU) :: ZDIR_ALB ! Initialization of total direct albedo
00152 REAL,    DIMENSION(KLU) :: ZSCA_ALB ! Initialization of total direct albedo
00153 REAL,    DIMENSION(KLU) :: ZICE_ALB ! Sea-ice albedo (from GELATO)
00154 !
00155 REAL    :: ZMIN, ZMAX
00156  CHARACTER(LEN=3)     :: HT
00157 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00158 !
00159 IF (LHOOK) CALL DR_HOOK('PUT_SFXCPL_N:TREAT_SURF',0,ZHOOK_HANDLE)
00160 !
00161 IF (YTYPE=='S') THEN
00162   CALL GET_1D_MASK(KLU,KI,ZSEA,IMASK)
00163 ELSEIF (YTYPE=='W') THEN
00164   CALL GET_1D_MASK(KLU,KI,ZWATER,IMASK)
00165 ENDIF
00166 !
00167  CALL PACK_SAME_RANK(IMASK,PICE       (:),ZICE    (:))
00168  CALL PACK_SAME_RANK(IMASK,PSST       (:),ZTS     (:))
00169  CALL PACK_SAME_RANK(IMASK,PTICE      (:),ZTICE   (:))
00170  CALL PACK_SAME_RANK(IMASK,PALB_SEAICE(:),ZDIR_ALB(:))
00171  CALL PACK_SAME_RANK(IMASK,PALB_SEAICE(:),ZSCA_ALB(:))
00172  CALL PACK_SAME_RANK(IMASK,PALB_SEAICE(:),ZICE_ALB(:))
00173 !
00174 ZMIN=MINVAL(ZTS(:))
00175 ZMAX=MAXVAL(ZTS(:))
00176 !
00177 IF(ZMIN<=0.0.OR.ZMAX>500.)THEN
00178   IF (YTYPE=='S') THEN
00179     HT='SST'
00180   ELSEIF (YTYPE=='W') THEN
00181     HT='TS'
00182   ENDIF
00183   WRITE(ILUOUT,*)'!'
00184   WRITE(ILUOUT,*)'PUT_SFXCPL_n: '//HT//' not define over at least one point'
00185   WRITE(ILUOUT,*)'              MIN '//HT//' =',ZMIN,'MAX SST =',ZMAX
00186   WRITE(ILUOUT,*)'              There is certainly a problem between  '
00187   WRITE(ILUOUT,*)'              SURFEX and OASIS sea/land mask        '
00188   CALL ABOR1_SFX('PUT_SFXCPL_n: Abort -> '//HT//' not define               ')
00189   WRITE(ILUOUT,*)'!'
00190 ENDIF
00191 !
00192 WHERE(ZICE(:)>=XICEC)
00193   ZTS (:) = MIN(ZTS(:),XTTS-0.01)
00194 ELSEWHERE
00195   ZTS (:) = MAX(ZTS(:), XTTS)
00196 ENDWHERE
00197 !
00198 IF (YTYPE=='S') THEN
00199   CALL PUT_RAD_SEA_n(HPROGRAM,KLU,ZTS,ZTICE,ZDIR_ALB,ZSCA_ALB,ZICE_ALB)
00200   CALL PACK_SAME_RANK(IMASK,PUMER(:),XUMER(:))
00201   CALL PACK_SAME_RANK(IMASK,PVMER(:),XVMER(:))
00202 ELSEIF (YTYPE=='W') THEN
00203   CALL PUT_RAD_WAT_n(HPROGRAM,KLU,ZTS,ZTICE,ZDIR_ALB,ZSCA_ALB,ZICE_ALB)
00204 ENDIF
00205 !
00206 IF (LHOOK) CALL DR_HOOK('PUT_SFXCPL_N:TREAT_SURF',1,ZHOOK_HANDLE)
00207 !
00208 END SUBROUTINE TREAT_SURF
00209 !
00210 !==============================================================================
00211 !
00212 END SUBROUTINE PUT_SFXCPL_n