Forked from
Méso-NH / Méso-NH code
4154 commits behind the upstream repository.
radtr_satel.f90 25.93 KiB
!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
!MNH_LIC for details. version 1.
!-----------------------------------------------------------------
!--------------- special set of characters for RCS information
!-----------------------------------------------------------------
! $Source$ $Revision$
!-----------------------------------------------------------------
! #######################
MODULE MODI_RADTR_SATEL
! #######################
INTERFACE
!
SUBROUTINE RADTR_SATEL(KYEARF, KMONTHF, KDAYF, PSECF, &
KDLON, KFLEV, KSTATM, KRAD_COLNBR, PEMIS, PCCO2, &
PTSRAD, PSTATM, PTHT, PRT, PPABST, PZZ, &
PSIGS, PMFCONV, PCLDFR, OUSERI, OSIGMAS, &
OSUBG_COND, ORAD_SUBG_COND, PIRBT, PWVBT, KGEO,PSIGQSAT )
!
INTEGER, INTENT(IN) :: KYEARF ! year of Final date
INTEGER, INTENT(IN) :: KMONTHF ! month of Final date
INTEGER, INTENT(IN) :: KDAYF ! day of Final date
REAL, INTENT(IN) :: PSECF ! number of seconds since date at 00 UTC
!
INTEGER, INTENT(IN) :: KDLON !number of columns where the
!radiation calculations are performed
INTEGER, INTENT(IN) :: KFLEV !number of vertical levels where the
!radiation calculations are performed
INTEGER, INTENT(IN) :: KSTATM !index of the standard atmosphere level
!just above the model top
INTEGER, INTENT(IN) :: KRAD_COLNBR !factor by which the memory is splitted
!
REAL, DIMENSION(:,:), INTENT(IN) :: PEMIS !Surface IR EMISsivity
REAL, INTENT(IN) :: PCCO2 !CO2 content
REAL, DIMENSION(:,:), INTENT(IN) :: PTSRAD !RADiative Surface Temperature
REAL, DIMENSION(:,:), INTENT(IN) :: PSTATM !selected standard atmosphere
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT !THeta at t
REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT !moist variables at t
REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST !pressure at t
REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ !Model level heights
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PSIGS ! Sigma_s from turbulence scheme
REAL, DIMENSION(:,:,:), INTENT(IN) :: PMFCONV! convective mass flux (kg /s m^2)
REAL, DIMENSION(:,:,:), INTENT(IN) :: PCLDFR ! cloud fraction
!
LOGICAL, INTENT(IN) :: OUSERI ! logical switch to compute both
! liquid and solid condensate (OUSERI=.TRUE.)
! or only liquid condensate (OUSERI=.FALSE.)
LOGICAL, INTENT(IN) :: OSIGMAS! use present global Sigma_s values
! or that from turbulence scheme
LOGICAL, INTENT(IN) :: OSUBG_COND ! Switch for Subgrid Condensation
! (prognotic mode)
LOGICAL, INTENT(IN) :: ORAD_SUBG_COND ! Switch for Subgrid Condensation
! (diagnostic mode)
!
REAL, DIMENSION(:,:), INTENT(OUT):: PIRBT !IR Brightness Temp. (K)
REAL, DIMENSION(:,:), INTENT(OUT):: PWVBT !WV Brightness Temp. (K)
!
INTEGER, INTENT(IN) :: KGEO !SATELLITE INDEX
REAL, INTENT(IN) :: PSIGQSAT ! use an extra "qsat" variance contribution (OSIGMAS case)
!
END SUBROUTINE RADTR_SATEL
END INTERFACE
END MODULE MODI_RADTR_SATEL
! #####################################################################
SUBROUTINE RADTR_SATEL(KYEARF, KMONTHF, KDAYF, PSECF, &
KDLON, KFLEV, KSTATM, KRAD_COLNBR, PEMIS, PCCO2, &
PTSRAD, PSTATM, PTHT, PRT, PPABST, PZZ, & PSIGS, PMFCONV, PCLDFR, OUSERI, OSIGMAS, &
OSUBG_COND, ORAD_SUBG_COND, PIRBT, PWVBT, KGEO,PSIGQSAT)
! #####################################################################
!
!!**** *RADTR_SATEL* -
!!
!! PURPOSE
!! -------
!!
!!** METHOD
!! ------
!!
!! EXTERNAL
!! --------
!!
!! IMPLICIT ARGUMENTS
!! ------------------
!!
!! REFERENCE
!! ---------
!! Chaboureau, J.-P., J.-P. Cammas, P. Mascart, J.-P. Pinty, C. Claud, R. Roca,
!! and J.-J. Morcrette, 2000: Evaluation of a cloud system life-cycle simulated
!! by Meso-NH during FASTEX using METEOSAT radiances and TOVS-3I cloud retrievals.
!! Q. J. R. Meteorol. Soc., 126, 1735-1750.
!! Chaboureau, J.-P. and P. Bechtold, 2002: A simple cloud parameterization from
!! cloud resolving model data: Theory and application. J. Atmos. Sci., 59, 2362-2372.
!!
!! AUTHOR
!! ------
!! J.-P. Chaboureau *L.A.*
!!
!! MODIFICATIONS
!! -------------
!! Original 29/03/00
!! J.-P. Chaboureau 15/04/03 add call to the subgrid condensation scheme
!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
!! G.Delautier 04/2016 : BUG JPHEXT
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
! ------------
!
USE MODD_CST
USE MODD_PARAMETERS
USE MODD_GRID_n
!
USE MODD_RAD_TRANSF
USE MODE_ll
!
USE MODI_INIT_NBMOD
USE MODI_DETER_ANGLE
USE MODI_MAKE_RADSAT
!
USE MODI_CONDENSATION
!
IMPLICIT NONE
!
!* 0.1 DECLARATIONS OF DUMMY ARGUMENTS :
!
INTEGER, INTENT(IN) :: KYEARF ! year of Final date
INTEGER, INTENT(IN) :: KMONTHF ! month of Final date
INTEGER, INTENT(IN) :: KDAYF ! day of Final date
REAL, INTENT(IN) :: PSECF ! number of seconds since date at 00 UTC
!
INTEGER, INTENT(IN) :: KDLON !number of columns where the
! radiation calculations are performed
INTEGER, INTENT(IN) :: KFLEV !number of vertical levels where the
! radiation calculations are performed
INTEGER, INTENT(IN) :: KSTATM !index of the standard atmosphere level
!just above the model topINTEGER, INTENT(IN) :: KRAD_COLNBR !factor by which the memory is splitted
!
REAL, DIMENSION(:,:), INTENT(IN) :: PEMIS !Surface IR EMISsivity
REAL, INTENT(IN) :: PCCO2 !CO2 content
REAL, DIMENSION(:,:), INTENT(IN) :: PTSRAD !RADiative Surface Temperature
REAL, DIMENSION(:,:), INTENT(IN) :: PSTATM !selected standard atmosphere
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT !THeta at t
REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT !moist variables at t
REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST !pressure at t
REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ !Model level heights
!
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PSIGS ! Sigma_s from turbulence scheme
REAL, DIMENSION(:,:,:), INTENT(IN) :: PMFCONV! convective mass flux (kg /s m^2)
REAL, DIMENSION(:,:,:), INTENT(IN) :: PCLDFR ! cloud fraction
!
LOGICAL, INTENT(IN) :: OUSERI ! logical switch to compute both
! liquid and solid condensate (OUSERI=.TRUE.)
! or only liquid condensate (OUSERI=.FALSE.)
LOGICAL, INTENT(IN) :: OSIGMAS! use present global Sigma_s values
! or that from turbulence scheme
LOGICAL, INTENT(IN) :: OSUBG_COND ! Switch for Subgrid Condensation
! (prognotic mode)
LOGICAL, INTENT(IN) :: ORAD_SUBG_COND ! Switch for Subgrid Condensation
! (diagnostic mode)
!
REAL, DIMENSION(:,:), INTENT(OUT):: PIRBT !IR Brightness Temp. (K)
REAL, DIMENSION(:,:), INTENT(OUT):: PWVBT !WV Brightness Temp. (K)
!
INTEGER, INTENT(IN) :: KGEO !SATELLITE INDEX
REAL, INTENT(IN) :: PSIGQSAT ! use an extra "qsat" variance contribution (OSIGMAS case)
!
!* 0.2 DECLARATIONS OF LOCAL VARIABLES
!
LOGICAL :: GPTDEP, GPVOIGT
!
! reference state
!from inprof
INTEGER :: IGL, ICABS, ING1, IUABS, IINIS, IENDS, ICONF, ICLOUD, IOVLP
INTEGER :: IH2O, ICO2, IO3, ICNT, IN2O, ICH4, ICO, IC11, IC12, ICFC
!
LOGICAL, DIMENSION(KDLON) :: GDOIT_2D ! .TRUE. for the larger scale
LOGICAL, DIMENSION(KDLON,KFLEV) :: GDOIT ! .TRUE. for all the levels of the
! larger scale columns
!
INTEGER :: JI,JJ,JK,JK1,JK2,JKRAD ! loop indexes
!
INTEGER :: IIB,IIE ! I index value of the first/last inner mass point
INTEGER :: IJB,IJE ! J index value of the first/last inner mass point
INTEGER :: IKB,IKE ! K index value of the first/last inner mass point
INTEGER :: IIU ! array size for the first index
INTEGER :: IJU ! array size for the second index
INTEGER :: IKU ! array size for the third index
INTEGER :: IIJ ! reformatted array index
INTEGER :: IKSTAE ! level number of the STAndard atmosphere array
INTEGER :: IKUP ! vertical level above which STAndard atmosphere data
INTEGER :: IDOIT_COL ! number of larger scale columns
INTEGER :: IDOIT ! number of levels corresponding of the larger scale
! columns are filled in
INTEGER :: IDIM ! effective number of columns for which the radiation
! code is run
INTEGER, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,3)) :: IKKOZ ! indice array used to
! vertically interpolate the ozone content on the model grid
!
REAL, DIMENSION(:,:), ALLOCATABLE :: ZTAVE ! mean-layer temperature
REAL, DIMENSION(:,:), ALLOCATABLE :: ZQVAVE ! mean-layer specific humidity
REAL, DIMENSION(:,:), ALLOCATABLE :: ZO3AVE ! mean-layer ozone content
REAL, DIMENSION(:,:), ALLOCATABLE :: ZPRES_HL ! half-level pressure
REAL, DIMENSION(:,:), ALLOCATABLE :: ZT_HL ! half-level temperatureREAL, DIMENSION(:,:), ALLOCATABLE :: ZCLDLD ! Downward cloud emissivity
REAL, DIMENSION(:,:), ALLOCATABLE :: ZCLDLU ! Upward cloud emissivity
REAL, DIMENSION(:), ALLOCATABLE :: ZVIEW ! cosecant of viewing angle
REAL, DIMENSION(:), ALLOCATABLE :: ZREMIS ! Reformatted PEMIS array
REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZEXNT ! Exner function
REAL, DIMENSION(SIZE(PSTATM,1)) :: ZSTAZZ,ZSTAOZ ! STAndard atmosphere height
! and OZone content
REAL :: ZOZ ! variable used to interpolate the ozone profile
!
REAL, DIMENSION(:), ALLOCATABLE :: ZDT0 ! surface discontinuity
REAL, DIMENSION(:,:), ALLOCATABLE :: ZRADBT
REAL, DIMENSION(:,:), ALLOCATABLE :: ZRADBC
REAL, DIMENSION(:,:), ALLOCATABLE :: ZRADFT
REAL, DIMENSION(:), ALLOCATABLE :: ZULAT
REAL, DIMENSION(:), ALLOCATABLE :: ZULON
!
REAL, DIMENSION(:,:), ALLOCATABLE :: ZZRADFT
!
REAL, DIMENSION(:), ALLOCATABLE :: ZWORK1, ZWORK3
!
! splitted arrays used to split the memory required by the ECMWF_radiation
! subroutine, the fields have the same meaning as their complete counterpart
REAL, DIMENSION(:), ALLOCATABLE :: ZREMIS_SPLIT
REAL, DIMENSION(:,:), ALLOCATABLE :: ZO3AVE_SPLIT
REAL, DIMENSION(:,:), ALLOCATABLE :: ZT_HL_SPLIT
REAL, DIMENSION(:,:), ALLOCATABLE :: ZPRES_HL_SPLIT
REAL, DIMENSION(:,:), ALLOCATABLE :: ZQVAVE_SPLIT
REAL, DIMENSION(:,:), ALLOCATABLE :: ZTAVE_SPLIT
REAL, DIMENSION(:,:), ALLOCATABLE :: ZCLDLD_SPLIT
REAL, DIMENSION(:,:), ALLOCATABLE :: ZCLDLU_SPLIT
REAL, DIMENSION(:), ALLOCATABLE :: ZVIEW_SPLIT
REAL, DIMENSION(:), ALLOCATABLE :: ZDT0_SPLIT
REAL, DIMENSION(:,:), ALLOCATABLE :: ZRADBT_SPLIT
REAL, DIMENSION(:,:), ALLOCATABLE :: ZRADBC_SPLIT
!
INTEGER :: JI_SPLIT ! loop on the splitted array
INTEGER :: INUM_CALL ! number of CALL of the radiation scheme
INTEGER :: IDIM_EFF ! effective number of air-columns to compute
INTEGER :: IDIM_RESIDUE ! number of remaining air-columns to compute
INTEGER :: IBEG, IEND ! auxiliary indices
!
! Other arrays for emissivity
REAL :: ZFLWP, ZFIWP, ZANGCOR, ZRADLP, ZMULTS, ZTMP, ZKI
!
! Other arrays for condensation
REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZTEMP ! Temperature
REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZSIGRC ! s r_c / sig_s^2
REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZNCLD ! grid scale cloud fraction
REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZRC ! grid scale r_c mixing ratio (kg/kg)
REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZRI ! grid scale r_i (kg/kg)
!----------------------------------------------------------------------------
!
!* 1. INITIALIZATION OF CONSTANTS FOR TRANSFERT CODE
! ----------------------------------------------
!
CALL INIT_NBMOD(KFLEV, IGL, ICABS, ING1, IUABS, IINIS, IENDS, &
IH2O, ICO2, IO3, ICNT, IN2O, ICH4, ICO, IC11, IC12, ICFC, &
ICONF, ICLOUD, IOVLP, GPVOIGT, GPTDEP)
X1CO2 = PCCO2 / 44.0 * XMD
!
!----------------------------------------------------------------------------
!
!* 2. COMPUTE DIMENSIONS OF ARRAYS AND OTHER INDICES
! ----------------------------------------------
!
IIU = SIZE(PTHT,1)
IJU = SIZE(PTHT,2)
IKU = SIZE(PTHT,3)
CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
IKB = 1 + JPVEXTIKE = IKU - JPVEXT
!
IKSTAE = SIZE(PSTATM,1)
IKUP = IKE-JPVEXT+1
!
!----------------------------------------------------------------------------
!
!* 3. INITIALIZES THE MEAN-LAYER VARIABLES
! ------------------------------------
!
ALLOCATE(ZEXNT(SIZE(PTHT,1),SIZE(PTHT,2),SIZE(PTHT,3)))
ZEXNT(:,:,:)= ( PPABST(:,:,:)/XP00 ) ** (XRD/XCPD)
!
ALLOCATE(ZTAVE(KDLON,KFLEV))
ALLOCATE(ZQVAVE(KDLON,KFLEV))
!
ZQVAVE(:,:) = 0.0
!
DO JK=IKB,IKE
JKRAD = JK-JPVEXT
DO JJ=IJB,IJE
DO JI=IIB,IIE
IIJ = 1 + (JI-IIB) + (IIE-IIB+1)*(JJ-IJB)
ZTAVE(IIJ,JKRAD) = PTHT(JI,JJ,JK)*ZEXNT(JI,JJ,JK)
END DO
END DO
END DO
!
! Check if the humidity mixing ratio is available
!
IF( SIZE(PRT(:,:,:,:),4) >= 1 ) THEN
DO JK=IKB,IKE
JKRAD = JK-JPVEXT
DO JJ=IJB,IJE
DO JI=IIB,IIE
IIJ = 1 + (JI-IIB) + (IIE-IIB+1)*(JJ-IJB)
ZQVAVE(IIJ,JKRAD) = PRT(JI,JJ,JK,1)
END DO
END DO
END DO
END IF
!
! Standard atmosphere extension
!
DO JK=IKUP,KFLEV
JK1 = (KSTATM-1)+(JK-IKUP)
JK2 = JK1+1
ZTAVE(:,JK) = 0.5*( PSTATM(JK1,3)+PSTATM(JK2,3) )
ZQVAVE(:,JK) = 0.5*( PSTATM(JK1,5)/PSTATM(JK1,4)+ &
PSTATM(JK2,5)/PSTATM(JK2,4) )
END DO
!
!----------------------------------------------------------------------------
!
!* 4. INITIALIZES THE HALF-LEVEL VARIABLES
! ------------------------------------
!
ALLOCATE(ZPRES_HL(KDLON,KFLEV+1))
ALLOCATE(ZT_HL(KDLON,KFLEV+1))
!
DO JK=IKB,IKE+1
JKRAD = JK-JPVEXT
DO JJ=IJB,IJE
DO JI=IIB,IIE
IIJ = 1 + (JI-IIB) + (IIE-IIB+1)*(JJ-IJB)
ZPRES_HL(IIJ,JKRAD) = XP00 * &
(0.5*(ZEXNT(JI,JJ,JK)+ZEXNT(JI,JJ,JK-1)))**(XCPD/XRD)
END DO
END DO
END DO!
! Standard atmosphere extension
! begining at ikup+1 level allows to use a model domain higher than 50km
!
DO JK=IKUP+1,KFLEV+1
JK1 = (KSTATM-1)+(JK-IKUP)
ZPRES_HL(:,JK) = PSTATM(JK1,2)*100.0
END DO
!
! Surface temperature at the first level
DO JJ=IJB,IJE
DO JI=IIB,IIE
IIJ = 1 + (JI-IIB) + (IIE-IIB+1)*(JJ-IJB)
ZT_HL(IIJ,1) = PTSRAD(JI,JJ)
END DO
END DO
!
! Temperature at half levels
ZT_HL(:,2:IKE-JPVEXT) = 0.5*(ZTAVE(:,1:IKE-JPVEXT-1)+ZTAVE(:,2:IKE-JPVEXT))
!
DO JJ=IJB,IJE
DO JI=IIB,IIE
IIJ = 1 + (JI-IIB) + (IIE-IIB+1)*(JJ-IJB)
ZT_HL(IIJ,IKE-JPVEXT+1) = 0.5*PTHT(JI,JJ,IKE )*ZEXNT(JI,JJ,IKE ) &
+ 0.5*PTHT(JI,JJ,IKE+1)*ZEXNT(JI,JJ,IKE+1)
END DO
END DO
!
! Standard atmosphere extension
! begining at ikup+1 level allows to use a model domain higher than 50km
!
DO JK=IKUP+1,KFLEV+1
JK1 = (KSTATM-1)+(JK-IKUP)
ZT_HL(:,JK) = PSTATM(JK1,3)
END DO
!
!----------------------------------------------------------------------------
!
!* 5. INITIALIZES THE OZONE PROFILES from the standard atmosphere
! ------------------------------
!
ALLOCATE(ZO3AVE(KDLON,KFLEV))
!
ZSTAOZ(:) = PSTATM(:,6)/PSTATM(:,4)
ZSTAZZ(:) = 1000.0*PSTATM(:,1)
!
DO JJ = IJB,IJE
DO JK2 = IKB,IKE
JKRAD = JK2-JPVEXT
IKKOZ(:,JK2) = IKB-1
DO JK1 = 1,IKSTAE
DO JI = IIB,IIE
IKKOZ(JI,JK2)=IKKOZ(JI,JK2) + NINT(0.5 + SIGN(0.5, &
-ZSTAZZ(JK1)+0.5*(PZZ(JI,JJ,JK2)+PZZ(JI,JJ,JK2+1)) ))
END DO
END DO
DO JI = IIB,IIE
ZOZ=(0.5*(PZZ(JI,JJ,JK2)+PZZ(JI,JJ,JK2+1))- ZSTAZZ(IKKOZ(JI,JK2))) &
/( ZSTAZZ(IKKOZ(JI,JK2)+1) - ZSTAZZ(IKKOZ(JI,JK2)))
IIJ = 1 + (JI-IIB) + (IIE-IIB+1)*(JJ-IJB)
ZO3AVE(IIJ,JKRAD) =( (1.- ZOZ) * ZSTAOZ(IKKOZ(JI,JK2)) &
+ ZOZ * ZSTAOZ(IKKOZ(JI,JK2)+1))
END DO
END DO
END DO
!
DO JK=IKUP,KFLEV
JK1 = (KSTATM)+(JK-IKUP)
ZO3AVE(:,JK) = ZSTAOZ(JK1)
END DO!
!----------------------------------------------------------------------------
!
!* 6. CALLS THE E.C.M.W.F. RADIATION CODE
! -----------------------------------
!
!* 6.1 INITIALIZES 2D AND SURFACE FIELDS
!
ALLOCATE(ZREMIS(KDLON))
DO JJ=IJB,IJE
DO JI=IIB,IIE
IIJ = 1 + (JI-IIB) + (IIE-IIB+1)*(JJ-IJB)
ZREMIS(IIJ) = PEMIS(JI,JJ)
END DO
END DO
!
! initializes surface discontinuity field
ALLOCATE(ZDT0(KDLON))
DO JJ=IJB,IJE
DO JI=IIB,IIE
IIJ = 1 + (JI-IIB) + (IIE-IIB+1)*(JJ-IJB)
ZDT0(IIJ) = PTSRAD(JI,JJ) - PTHT(JI,JJ,1)*ZEXNT(JI,JJ,1)
END DO
END DO
!
ALLOCATE(ZULAT(KDLON))
ALLOCATE(ZULON(KDLON))
DO JJ=IJB,IJE
DO JI=IIB,IIE
IIJ = 1 + (JI-IIB) + (IIE-IIB+1)*(JJ-IJB)
ZULON(IIJ) = XLON(JI,JJ)
ZULAT(IIJ) = XLAT(JI,JJ)
END DO
END DO
ALLOCATE(ZVIEW(KDLON))
CALL DETER_ANGLE(KGEO, KDLON, ZULAT, ZULON, ZVIEW)
DEALLOCATE(ZULAT)
DEALLOCATE(ZULON)
!
!
ALLOCATE(ZCLDLD(KDLON,KFLEV))
ALLOCATE(ZCLDLU(KDLON,KFLEV))
ZCLDLD = 0.
ZCLDLU = 0.
!
IF( SIZE(PRT(:,:,:,:),4) >= 2 ) THEN
ALLOCATE(ZNCLD(IIU,IJU,IKU))
ALLOCATE(ZRC(IIU,IJU,IKU))
ZRC=PRT(:,:,:,2)
ALLOCATE(ZRI(IIU,IJU,IKU))
ZRI=0.
IF( OUSERI ) ZRI=PRT(:,:,:,4)
IF ( .NOT. OSUBG_COND .AND. ORAD_SUBG_COND) THEN
PRINT*,' THE SUBGRID CONDENSATION SCHEME IN DIAGNOSTIC MODE IS ACTIVATED'
ALLOCATE(ZTEMP(IIU,IJU,IKU))
ZTEMP=PTHT*ZEXNT
ALLOCATE(ZSIGRC(IIU,IJU,IKU))
CALL CONDENSATION( IIU, IJU, IKU, IIB, IIE, IJB, IJE, IKB, IKE,1,&
PPABST, PZZ, ZTEMP, PRT(:,:,:,1), ZRC, ZRI, PSIGS, &
PMFCONV, ZNCLD, ZSIGRC, OUSERI, OSIGMAS,PSIGQSAT )
DEALLOCATE(ZTEMP,ZSIGRC)
ELSE
ZNCLD=PCLDFR
END IF
DO JK=IKB,IKE-1
JKRAD = JK-JPVEXT
DO JJ=IJB,IJE
DO JI=IIB,IIE
IIJ = 1 + (JI-IIB) + (IIE-IIB+1)*(JJ-IJB)
IF ( ZVIEW(IIJ) /= XUNDEF .AND. & (ZRC(JI,JJ,JK) > 0. .OR. ZRI(JI,JJ,JK) > 0. ) ) THEN
ZFLWP = ZRC(JI,JJ,JK) / XG /MAX(1.E-10,ZNCLD(JI,JJ,JK)) &
* (PPABST(JI,JJ,JK)-PPABST(JI,JJ,JK+1))
ZFIWP = ZRI(JI,JJ,JK) / XG /MAX(1.E-10,ZNCLD(JI,JJ,JK)) &
* (PPABST(JI,JJ,JK)-PPABST(JI,JJ,JK+1))
ZANGCOR = ZVIEW(IIJ) / 1.66
!!!Parametrization following Ou and Chou, 1995 (Atmos. Res.)
ZTMP = ZTAVE(IIJ,JKRAD)-XTT !ZTMP in Celsius degree
ZRADLP = 326.3+12.42*ZTMP+0.197*(ZTMP**2)+0.0012*(ZTMP**3)
ZRADLP = MIN(140., MAX(20., ZRADLP))
!!! Parametrization following Ebert and Curry, 1992 (JGR-d)
ZKI = 0.3 + 1290. / ZRADLP
ZCLDLD(IIJ,JKRAD) = ZNCLD(JI,JJ,JK)*(1.-EXP &
( -158.*ZFLWP *ZANGCOR-ZKI*ZFIWP*ZVIEW(IIJ)))
ZCLDLU(IIJ,JKRAD) = ZNCLD(JI,JJ,JK)*(1.-EXP &
( -130.*ZFLWP *ZANGCOR-ZKI*ZFIWP*ZVIEW(IIJ)))
END IF
END DO
END DO
END DO
DEALLOCATE(ZNCLD,ZRC,ZRI)
END IF
!
DEALLOCATE(ZEXNT)
!
GDOIT_2D(:) = .FALSE.
!
! Flags the columns for which the computations have to be performed
!
DO JJ=IJB,IJE
DO JI=IIB,IIE
IIJ = 1 + (JI-IIB) + (IIE-IIB+1)*(JJ-IJB)
IF (ZVIEW(IIJ) /= XUNDEF) GDOIT_2D(IIJ) = .TRUE.
END DO
END DO
IDOIT_COL = COUNT( GDOIT_2D(:) ) ! number of larger scale columns
!
GDOIT(:,:) = SPREAD( GDOIT_2D(:),DIM=2,NCOPIES=KFLEV )
IDOIT = IDOIT_COL*KFLEV
ALLOCATE(ZWORK1(IDOIT))
!
! temperature profiles
ZWORK1(:) = PACK( ZTAVE(:,:),MASK=GDOIT(:,:) )
DEALLOCATE(ZTAVE)
ALLOCATE(ZTAVE(IDOIT_COL,KFLEV))
ZTAVE(:,:) = RESHAPE( ZWORK1(:),(/IDOIT_COL,KFLEV/) )
!
! vapor mixing ratio profiles
ZWORK1(:) = PACK( ZQVAVE(:,:),MASK=GDOIT(:,:) )
DEALLOCATE(ZQVAVE)
ALLOCATE(ZQVAVE(IDOIT_COL,KFLEV))
ZQVAVE(:,:) = RESHAPE( ZWORK1(:),(/IDOIT_COL,KFLEV/) )
!
! cloud emissivities
ZWORK1(:) = PACK( ZCLDLD(:,:),MASK=GDOIT(:,:) )
DEALLOCATE(ZCLDLD)
ALLOCATE(ZCLDLD(IDOIT_COL,KFLEV))
ZCLDLD(:,:) = RESHAPE( ZWORK1(:),(/IDOIT_COL,KFLEV/) )
!
ZWORK1(:) = PACK( ZCLDLU(:,:),MASK=GDOIT(:,:) )
DEALLOCATE(ZCLDLU)
ALLOCATE(ZCLDLU(IDOIT_COL,KFLEV))
ZCLDLU(:,:) = RESHAPE( ZWORK1(:),(/IDOIT_COL,KFLEV/) )
!
! ozone content profiles
ZWORK1(:) = PACK( ZO3AVE(:,:),MASK=GDOIT(:,:) )
DEALLOCATE(ZO3AVE)
ALLOCATE(ZO3AVE(IDOIT_COL,KFLEV))
ZO3AVE(:,:) = RESHAPE( ZWORK1(:),(/IDOIT_COL,KFLEV/) )
!! half-level variables
ZWORK1(:) = PACK( ZPRES_HL(:,1:KFLEV),MASK=GDOIT(:,:) )
DEALLOCATE(ZPRES_HL)
ALLOCATE(ZPRES_HL(IDOIT_COL,KFLEV+1))
ZPRES_HL(:,1:KFLEV) = RESHAPE( ZWORK1(:),(/IDOIT_COL,KFLEV/) )
ZPRES_HL(:,KFLEV+1) = PSTATM(IKSTAE,2)*100.0
!
ZWORK1(:) = PACK( ZT_HL(:,1:KFLEV),MASK=GDOIT(:,:) )
DEALLOCATE(ZT_HL)
ALLOCATE(ZT_HL(IDOIT_COL,KFLEV+1))
ZT_HL(:,1:KFLEV) = RESHAPE( ZWORK1(:),(/IDOIT_COL,KFLEV/) )
ZT_HL(:,KFLEV+1) = PSTATM(IKSTAE,3)
!
! surface fields
ALLOCATE(ZWORK3(IDOIT_COL))
ZWORK3(:) = PACK( ZVIEW(:),MASK=GDOIT_2D(:) )
DEALLOCATE(ZVIEW)
ALLOCATE(ZVIEW(IDOIT_COL))
ZVIEW(:) = ZWORK3(:)
!
ZWORK3(:) = PACK( ZREMIS(:),MASK=GDOIT_2D(:) )
DEALLOCATE(ZREMIS)
ALLOCATE(ZREMIS(IDOIT_COL))
ZREMIS(:) = ZWORK3(:)
!
ZWORK3(:) = PACK( ZDT0(:),MASK=GDOIT_2D(:) )
DEALLOCATE(ZDT0)
ALLOCATE(ZDT0(IDOIT_COL))
ZDT0(:) = ZWORK3(:)
!
DEALLOCATE(ZWORK1)
DEALLOCATE(ZWORK3)
!
! radiation fields
ALLOCATE(ZRADBC(IDOIT_COL,JPWVINT))
ALLOCATE(ZRADBT(IDOIT_COL,JPWVINT))
!
IDIM = IDOIT_COL
PRINT *,'KGEO =',KGEO,' IDIM =',IDIM
!
!* 6.2 CALLS THE ECMWF_RADIATION ROUTINES
!
! ***********************************************************
! *CAUTION: Routine nbmvec is written in FORTRAN 77*
! ***********************************************************
!
! mixing ratio -> specific humidity conversion
ZQVAVE(:,:) = ZQVAVE(:,:) / (1.+ZQVAVE(:,:))
!
IF( IDIM <= KRAD_COLNBR ) THEN
!
! there is less than KRAD_COLNBR verticals to be considered therefore
! no split of the arrays is performed
!
CALL NBMVEC( 1, IDIM, IDIM, KFLEV, IGL, ICABS, ING1, IUABS, &
IH2O, ICO2, IO3, ICNT, IN2O, ICH4, ICO, IC11, IC12, ICFC, &
IINIS, IENDS, ICONF, ICLOUD, IOVLP, GPVOIGT, GPTDEP, &
ZTAVE, ZQVAVE, ZO3AVE, ZPRES_HL, ZT_HL, &
ZVIEW, ZCLDLD, ZCLDLU, ZDT0, ZREMIS, ZRADBC, ZRADBT)
ELSE
!
! the splitting of the arrays will be performed
!
INUM_CALL = CEILING( FLOAT( IDIM ) / FLOAT( KRAD_COLNBR ) )
IDIM_RESIDUE = IDIM
DO JI_SPLIT = 1 , INUM_CALL
IDIM_EFF = MIN( IDIM_RESIDUE,KRAD_COLNBR )
!
IF( JI_SPLIT == 1 .OR. JI_SPLIT == INUM_CALL ) THEN
ALLOCATE( ZREMIS_SPLIT(IDIM_EFF)) ALLOCATE( ZO3AVE_SPLIT(IDIM_EFF,KFLEV))
ALLOCATE( ZT_HL_SPLIT(IDIM_EFF,KFLEV+1))
ALLOCATE( ZPRES_HL_SPLIT(IDIM_EFF,KFLEV+1))
ALLOCATE( ZQVAVE_SPLIT(IDIM_EFF,KFLEV))
ALLOCATE( ZTAVE_SPLIT(IDIM_EFF,KFLEV))
ALLOCATE( ZCLDLU_SPLIT(IDIM_EFF,KFLEV))
ALLOCATE( ZCLDLD_SPLIT(IDIM_EFF,KFLEV))
ALLOCATE( ZVIEW_SPLIT(IDIM_EFF))
ALLOCATE( ZDT0_SPLIT(IDIM_EFF))
ALLOCATE( ZRADBT_SPLIT(IDIM_EFF,JPWVINT))
ALLOCATE( ZRADBC_SPLIT(IDIM_EFF,JPWVINT))
END IF
!
! fill the splitted arrays with their values
! taken from the full arrays
!
IBEG = IDIM-IDIM_RESIDUE+1
IEND = IBEG+IDIM_EFF-1
ZREMIS_SPLIT(:) = ZREMIS( IBEG:IEND )
ZO3AVE_SPLIT(:,:) = ZO3AVE( IBEG:IEND ,:)
ZT_HL_SPLIT(:,:) = ZT_HL( IBEG:IEND ,:)
ZPRES_HL_SPLIT(:,:) = ZPRES_HL( IBEG:IEND ,:)
ZQVAVE_SPLIT(:,:) = ZQVAVE( IBEG:IEND ,:)
ZTAVE_SPLIT(:,:) = ZTAVE ( IBEG:IEND ,:)
ZCLDLU_SPLIT(:,:) = ZCLDLU ( IBEG:IEND ,:)
ZCLDLD_SPLIT(:,:) = ZCLDLD ( IBEG:IEND ,:)
ZVIEW_SPLIT(:) = ZVIEW ( IBEG:IEND )
ZDT0_SPLIT(:) = ZDT0 ( IBEG:IEND )
!
! call ECMWF_radiation with the splitted arrays
!
CALL NBMVEC( 1, IDIM_EFF, IDIM_EFF, KFLEV, IGL, ICABS, ING1, IUABS,&
IH2O, ICO2, IO3, ICNT, IN2O, ICH4, ICO, IC11, IC12, ICFC, &
IINIS, IENDS, ICONF, ICLOUD, IOVLP, GPVOIGT, GPTDEP, &
ZTAVE_SPLIT, ZQVAVE_SPLIT, ZO3AVE_SPLIT, &
ZPRES_HL_SPLIT, ZT_HL_SPLIT, &
ZVIEW_SPLIT, ZCLDLD_SPLIT, ZCLDLU_SPLIT, ZDT0_SPLIT, &
ZREMIS_SPLIT, ZRADBC_SPLIT, ZRADBT_SPLIT)
!
! fill the full output arrays with the splitted arrays
!
ZRADBT( IBEG:IEND ,:) = ZRADBT_SPLIT(:,:)
ZRADBC( IBEG:IEND ,:) = ZRADBC_SPLIT(:,:)
!
IDIM_RESIDUE = IDIM_RESIDUE - IDIM_EFF
!
! desallocation of the splitted arrays
!
IF( JI_SPLIT >= INUM_CALL-1 ) THEN
DEALLOCATE(ZREMIS_SPLIT)
DEALLOCATE(ZO3AVE_SPLIT)
DEALLOCATE(ZT_HL_SPLIT)
DEALLOCATE(ZPRES_HL_SPLIT)
DEALLOCATE(ZQVAVE_SPLIT)
DEALLOCATE(ZTAVE_SPLIT)
DEALLOCATE(ZCLDLU_SPLIT)
DEALLOCATE(ZCLDLD_SPLIT)
DEALLOCATE(ZVIEW_SPLIT)
DEALLOCATE(ZDT0_SPLIT)
DEALLOCATE(ZRADBT_SPLIT)
DEALLOCATE(ZRADBC_SPLIT)
END IF
END DO
END IF
!
DEALLOCATE(ZTAVE,ZQVAVE,ZO3AVE)
DEALLOCATE(ZPRES_HL,ZT_HL)
DEALLOCATE(ZREMIS)
DEALLOCATE(ZDT0)
DEALLOCATE(ZCLDLD,ZCLDLU)DEALLOCATE(ZVIEW)
!
ZRADBT = ZRADBT / XPI
ALLOCATE(ZRADFT(IDIM,JPCAN))
CALL MAKE_RADSAT(KYEARF, KMONTHF, KDAYF, PSECF, &
KGEO, IDIM, ZRADBT, ZRADFT)
DEALLOCATE(ZRADBT)
DEALLOCATE(ZRADBC)
!
ALLOCATE(ZWORK1(IDIM*JPCAN))
ZWORK1(:) = PACK( ZRADFT(:,:),MASK=.TRUE. )
ALLOCATE(ZZRADFT(KDLON,JPCAN))
ZZRADFT(:,:) = UNPACK( ZWORK1(:),MASK=GDOIT(:,1:JPCAN),FIELD=XUNDEF )
DEALLOCATE(ZRADFT)
DEALLOCATE(ZWORK1)
!
PIRBT = XUNDEF
PWVBT = XUNDEF
DO JJ=IJB,IJE
DO JI=IIB,IIE
IIJ = 1 + (JI-IIB) + (IIE-IIB+1)*(JJ-IJB)
PIRBT(JI,JJ) = ZZRADFT(IIJ,1)
PWVBT(JI,JJ) = ZZRADFT(IIJ,2)
END DO
END DO
DEALLOCATE(ZZRADFT)
!
END SUBROUTINE RADTR_SATEL