!OPTIONS XOPT(NOEVAL) SUBROUTINE RECMWF (KST, KEND, KPROMA, KTDIA , KLEV,& & KMODE,& & PALBD , PALBP , PAPRS , PAPRSF , PCCO2 , PCLFR,& & PQO3 , PAER , PDP , PEMIS , PMU0,& & PQ , PQS , PQIWP , PQLWP , PSLM , PT , PTS,& & PREF_LIQ, PREF_ICE,& & PEMTD , PEMTU , PTRSO,& & PTH , PCTRSO, PCEMTR, PTRSOD,& & PLWFC, PLWFT, PSWFC, PSWFT, PSFSWDIR, PSFSWDIF,& & PFSDNN, PFSDNV,& & PPIZA_DST,PCGA_DST,PTAUREL_DST,PFLUX,PFLUC,& & PFSDN ,PFSUP , PFSCDN , PFSCUP) !**** *RECMWF* - METEO-FRANCE RADIATION INTERFACE TO ECMWF RADIATION SCHEME ! PURPOSE. ! -------- ! SIMPLE INTERFACE TO RADLSW (NO INTERPOLATION) !** INTERFACE. ! ---------- ! EXPLICIT ARGUMENTS : ! -------------------- ! KST : START INDEX OF DATA IN KPROMA-LONG VECTOR ! KEND : END INDEX OF DATA IN KPROMA-LONG VECTOR ! KPROMA : VECTOR LENGTH ! KTDIA : INDEX OF TOP LEVEL FROM WHICH COMPUTATIONS ARE ACTIVE ! KLEV : NUMBER OF LEVELS ! PAER : (KPROMA,KLEV ,6) ; OPTICAL THICKNESS OF THE AEROSOLS ! PALBD : (KPROMA,NSW) ; DIFFUSE ALBEDO IN THE 2 SW INTERVALS ! PALBP : (KPROMA,NSW) ; PARALLEL ALBEDO IN THE 2 SW INTERVALS ! PAPRS : (KPROMA,KLEV+1) ; HALF LEVEL PRESSURE ! PAPRSF : (KPROMA,KLEV ) ; FULL LEVEL PRESSURE ! PCCO2 : ; CONCENTRATION IN CO2 (PA/PA) ! PCLFR : (KPROMA,KLEV ) ; CLOUD FRACTIONAL COVER ! PQO3 : (KPROMA,KLEV ) ; OZONE MIXING RATIO (MASS) ! PDP : (KPROMA,KLEV) ; LAYER PRESSURE THICKNESS ! PEMIS : (KPROMA) ; SURFACE EMISSIVITY ! PMU0 : (KPROMA) ; SOLAR ANGLE ! PQ : (KPROMA,KLEV ) ; SPECIFIC HUMIDITY PA/PA ! PQS : (KPROMA,KLEV ) ; SATURATION SPECIFIC HUMIDITY PA/PA ! PQIWP : (KPROMA,KLEV ) ; ICE WATER KG/KG ! PQLWP : (KPROMA,KLEV ) ; LIQUID WATER KG/KG ! PSLM : (KPROMA) ; LAND-SEA MASK ! PT : (KPROMA,KLEV) ; FULL LEVEL TEMPERATURE ! PTS : (KPROMA) ; SURFACE TEMPERATURE ! PPIZA_DST : (KPROMA,KLEV,NSW); Single scattering albedo of dust ! PCGA_DST : (KPROMA,KLEV,NSW); Assymetry factor for dust ! PTAUREL_DST: (KPROMA,KLEV,NSW); Optical depth of dust relative to at 550nm ! PREF_LIQ (KPROMA,KLEV) ; Liquid droplet radius (um) ! PREF_ICE (KPROMA,KLEV) ; Ice crystal radius (um) ! ==== OUTPUTS === ! PEMTD (KPROMA,KLEV+1) ; TOTAL DOWNWARD LONGWAVE EMISSIVITY ! PEMTU (KPROMA,KLEV+1) ; TOTAL UPWARD LONGWAVE EMISSIVITY ! PTRSO (KPROMA,KLEV+1) ; TOTAL SHORTWAVE TRANSMISSIVITY ! PTH (KPROMA,KLEV+1) ; HALF LEVEL TEMPERATURE ! PCTRSO(KPROMA,2) ; CLEAR-SKY SHORTWAVE TRANSMISSIVITY ! PCEMTR(KPROMA,2) ; CLEAR-SKY NET LONGWAVE EMISSIVITY ! PTRSOD(KPROMA) ; TOTAL-SKY SURFACE SW TRANSMISSITY ! PLWFC (KPROMA,2) ; CLEAR-SKY LONGWAVE FLUXES ! PLWFT (KPROMA,KLEV+1) ; TOTAL-SKY LONGWAVE FLUXES ! PSWFC (KPROMA,2) ; CLEAR-SKY SHORTWAVE FLUXES ! PSWFT (KPROMA,KLEV+1) ; TOTAL-SKY SHORTWAVE FLUXES ! Ajout flux LW et SW montants et descendants, et ciel clair (MPL 19.12.08) ! PFLUX (KPROMA,2,KLEV+1) ; LW total sky flux (1=up, 2=down) ! PFLUC (KPROMA,2,KLEV+1) ; LW clear sky flux (1=up, 2=down) ! PFSDN(KPROMA,KLEV+1) ; SW total sky flux down ! PFSUP(KPROMA,KLEV+1) ; SW total sky flux up ! PFSCDN(KPROMA,KLEV+1) ; SW clear sky flux down ! PFSCUP(KPROMA,KLEV+1) ; SW clear sky flux up ! IMPLICIT ARGUMENTS : NONE ! -------------------- ! METHOD. ! ------- ! SEE DOCUMENTATION ! EXTERNALS. ! ---------- ! REFERENCE. ! ---------- ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS ! AUTHORS. ! -------- ! ORIGINAL BY B. RITTER *ECMWF* 83-10-13 ! REWRITING FOR IFS BY J.-J. MORCRETTE 94-11-15 ! 96-11: Ph. Dandin. Meteo-France ! REWRITING FOR DM BY J.PH. PIEDELIEVRE 1998-07 ! Duplication of RFMR to use present (cy25) ECMWF radiation scheme : Y. Bouteloup 09-2003 ! Use of 6 aerosols & introduce NSW : F. Bouyssel 09-2004 ! 04-11-18 : 4 New arguments for AROME : Y. Seity ! 2005-10-10 Y. Seity : 3 optional arguments for dust optical properties ! JJMorcrette 20060721 PP of clear-sky PAR and TOA incident solar radiation (ECMWF) !----------------------------------------------------------------------- USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK USE YOEAERD , ONLY : RCAEROS USE YOMCST , ONLY : RMD ,RMO3 USE YOMPHY3 , ONLY : RII0 !USE YOERAD , ONLY : NAER, NSW, RCCNLND ,RCCNSEA ! NSW mis dans ;def MPL 20140211 USE YOERAD , ONLY : NAER, RCCNLND ,RCCNSEA USE YOERDU , ONLY : REPSCQ USE YOMGEM , ONLY : NGPTOT USE YOERDI , ONLY : RRAE ,REPCLC ,REPH2O USE YOMARPHY , ONLY : LRDUST !----------------------------------------------------------------------- !* 0.1 ARGUMENTS. ! ---------- IMPLICIT NONE include "clesphys.h" INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA INTEGER(KIND=JPIM),INTENT(IN) :: KLEV INTEGER(KIND=JPIM),INTENT(IN) :: KST INTEGER(KIND=JPIM),INTENT(IN) :: KEND INTEGER(KIND=JPIM) :: KTDIA ! Argument NOT used INTEGER(KIND=JPIM),INTENT(IN) :: KMODE REAL(KIND=JPRB) ,INTENT(IN) :: PALBD(KPROMA,NSW) REAL(KIND=JPRB) ,INTENT(IN) :: PALBP(KPROMA,NSW) REAL(KIND=JPRB) ,INTENT(IN) :: PAPRS(KPROMA,KLEV+1) REAL(KIND=JPRB) ,INTENT(IN) :: PAPRSF(KPROMA,KLEV) REAL(KIND=JPRB) ,INTENT(IN) :: PCCO2 REAL(KIND=JPRB) ,INTENT(IN) :: PCLFR(KPROMA,KLEV) REAL(KIND=JPRB) ,INTENT(IN) :: PQO3(KPROMA,KLEV) REAL(KIND=JPRB) ,INTENT(IN) :: PAER(KPROMA,KLEV,6) REAL(KIND=JPRB) ,INTENT(IN) :: PDP(KPROMA,KLEV) REAL(KIND=JPRB) ,INTENT(IN) :: PEMIS(KPROMA) REAL(KIND=JPRB) ,INTENT(IN) :: PMU0(KPROMA) REAL(KIND=JPRB) ,INTENT(IN) :: PQ(KPROMA,KLEV) REAL(KIND=JPRB) ,INTENT(IN) :: PQS(KPROMA,KLEV) REAL(KIND=JPRB) ,INTENT(IN) :: PQIWP(KPROMA,KLEV) REAL(KIND=JPRB) ,INTENT(IN) :: PQLWP(KPROMA,KLEV) REAL(KIND=JPRB) ,INTENT(IN) :: PSLM(KPROMA) REAL(KIND=JPRB) ,INTENT(IN) :: PT(KPROMA,KLEV) REAL(KIND=JPRB) ,INTENT(IN) :: PTS(KPROMA) REAL(KIND=JPRB) ,INTENT(IN) :: PPIZA_DST(KPROMA,KLEV,NSW) REAL(KIND=JPRB) ,INTENT(IN) :: PCGA_DST(KPROMA,KLEV,NSW) REAL(KIND=JPRB) ,INTENT(IN) :: PTAUREL_DST(KPROMA,KLEV,NSW) REAL(KIND=JPRB) ,INTENT(IN) :: PREF_LIQ(KPROMA,KLEV) REAL(KIND=JPRB) ,INTENT(IN) :: PREF_ICE(KPROMA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: PEMTD(KPROMA,KLEV+1) REAL(KIND=JPRB) ,INTENT(OUT) :: PEMTU(KPROMA,KLEV+1) REAL(KIND=JPRB) ,INTENT(OUT) :: PTRSO(KPROMA,KLEV+1) REAL(KIND=JPRB) ,INTENT(INOUT) :: PTH(KPROMA,KLEV+1) REAL(KIND=JPRB) ,INTENT(OUT) :: PCTRSO(KPROMA,2) REAL(KIND=JPRB) ,INTENT(OUT) :: PCEMTR(KPROMA,2) REAL(KIND=JPRB) ,INTENT(OUT) :: PTRSOD(KPROMA) REAL(KIND=JPRB) ,INTENT(OUT) :: PLWFC(KPROMA,2) REAL(KIND=JPRB) ,INTENT(OUT) :: PLWFT(KPROMA,KLEV+1) REAL(KIND=JPRB) ,INTENT(OUT) :: PSWFC(KPROMA,2) REAL(KIND=JPRB) ,INTENT(OUT) :: PSWFT(KPROMA,KLEV+1) REAL(KIND=JPRB) ,INTENT(OUT) :: PSFSWDIR(KPROMA,NSW) REAL(KIND=JPRB) ,INTENT(OUT) :: PSFSWDIF(KPROMA,NSW) REAL(KIND=JPRB) ,INTENT(OUT) :: PFSDNN(KPROMA) REAL(KIND=JPRB) ,INTENT(OUT) :: PFSDNV(KPROMA) REAL(KIND=JPRB) ,INTENT(OUT) :: PFLUX(KPROMA,2,KLEV+1) ! LW total sky flux (1=up, 2=down) REAL(KIND=JPRB) ,INTENT(OUT) :: PFLUC(KPROMA,2,KLEV+1) ! LW clear sky flux (1=up, 2=down) REAL(KIND=JPRB) ,INTENT(OUT) :: PFSDN(KPROMA,KLEV+1) ! SW total sky flux down REAL(KIND=JPRB) ,INTENT(OUT) :: PFSUP(KPROMA,KLEV+1) ! SW total sky flux up REAL(KIND=JPRB) ,INTENT(OUT) :: PFSCDN(KPROMA,KLEV+1) ! SW clear sky flux down REAL(KIND=JPRB) ,INTENT(OUT) :: PFSCUP(KPROMA,KLEV+1) ! SW clear sky flux up ! ==== COMPUTED IN RADITE === ! ------------------------------------------------------------------ !* 0.2 LOCAL ARRAYS. ! ------------- REAL(KIND=JPRB) :: ZRAER (KPROMA,6,KLEV) REAL(KIND=JPRB) :: ZRCLC (KPROMA,KLEV) REAL(KIND=JPRB) :: ZRMU0 (KPROMA) REAL(KIND=JPRB) :: ZRPR (KPROMA,KLEV) REAL(KIND=JPRB) :: ZRTI (KPROMA,KLEV) REAL(KIND=JPRB) :: ZQLWP (KPROMA,KLEV ) , ZQIWP (KPROMA,KLEV ) REAL(KIND=JPRB) :: ZPQO3 (KPROMA,KLEV) REAL(KIND=JPRB) :: ZQOZ (NGPTOT,KLEV) REAL(KIND=JPRB) :: ZQS (KPROMA,KLEV) REAL(KIND=JPRB) :: ZQ (KPROMA,KLEV) REAL(KIND=JPRB) :: ZEMTD (KPROMA,KLEV+1) REAL(KIND=JPRB) :: ZEMTU (KPROMA,KLEV+1) REAL(KIND=JPRB) :: ZTRSOC (KPROMA,2) REAL(KIND=JPRB) :: ZEMTC (KPROMA,2) REAL(KIND=JPRB) :: ZNBAS (KPROMA) REAL(KIND=JPRB) :: ZNTOP (KPROMA) REAL(KIND=JPRB) :: ZQRAIN (KPROMA,KLEV) REAL(KIND=JPRB) :: ZQRAINT(KPROMA,KLEV) REAL(KIND=JPRB) :: ZCCNL (KPROMA) REAL(KIND=JPRB) :: ZCCNO (KPROMA) ! output of radlsw REAL(KIND=JPRB) :: ZEMIT (KPROMA) REAL(KIND=JPRB) :: ZFCT (KPROMA,KLEV+1) REAL(KIND=JPRB) :: ZFLT (KPROMA,KLEV+1) REAL(KIND=JPRB) :: ZFCS (KPROMA,KLEV+1) REAL(KIND=JPRB) :: ZFLS (KPROMA,KLEV+1) REAL(KIND=JPRB) :: ZFRSOD (KPROMA),ZSUDU(KPROMA) REAL(KIND=JPRB) :: ZPARF (KPROMA),ZUVDF(KPROMA),ZPARCF(KPROMA),ZTINCF(KPROMA) INTEGER(KIND=JPIM) :: IBEG, IEND, JK, JL REAL(KIND=JPRB) :: ZCRAE, ZRII0, ZEMIW(KPROMA) REAL(KIND=JPRB) :: ZHOOK_HANDLE #include "radlsw.intfb.h" IF (LHOOK) CALL DR_HOOK('RECMWF',0,ZHOOK_HANDLE) ! print *,'RECMWF: PTS=',PTS IBEG=KST IEND=KEND !* 1. PREPARATORY WORK ! ---------------- !* 1.1 LOCAL CONSTANTS ! --------------- ZRII0=RII0 !print *,'RECMWF: RII0 PMU0=',RII0,PMU0 ZCRAE=RRAE*(RRAE+2.0_JPRB) !* 2.1 FULL-LEVEL QUANTITIES ZRPR =PAPRSF DO JK=1,KLEV DO JL=IBEG,IEND ! ZPQO3(JL,JK)=PQO3(JL,JK)*PDP(JL,JK)*RMD/RMO3 ZPQO3(JL,JK)=PQO3(JL,JK)*PDP(JL,JK) ZRCLC(JL,JK)=MAX( 0.0_JPRB ,MIN( 1.0_JPRB ,PCLFR(JL,JK))) IF (ZRCLC(JL,JK) > REPCLC) THEN ZQLWP(JL,JK)=PQLWP(JL,JK) ZQIWP(JL,JK)=PQIWP(JL,JK) ELSE ZQLWP(JL,JK)=REPH2O*ZRCLC(JL,JK) ZQIWP(JL,JK)=REPH2O*ZRCLC(JL,JK) ENDIF ZQRAIN(JL,JK)=0. ZQRAINT(JL,JK)=0. ZRTI(JL,JK) =PT(JL,JK) ZQS (JL,JK)=MAX(2.0_JPRB*REPH2O,PQS(JL,JK)) ZQ (JL,JK)=MAX(REPH2O,MIN(PQ(JL,JK),ZQS(JL,JK)*(1.0_JPRB-REPH2O))) ZEMIW(JL)=PEMIS(JL) ENDDO ENDDO IF (NAER == 0) THEN ZRAER=RCAEROS ELSE DO JK=1,KLEV DO JL=IBEG,IEND ZRAER(JL,1,JK)=PAER(JL,JK,1) ZRAER(JL,2,JK)=PAER(JL,JK,2) ZRAER(JL,3,JK)=PAER(JL,JK,3) ZRAER(JL,4,JK)=PAER(JL,JK,4) ZRAER(JL,5,JK)=RCAEROS ZRAER(JL,6,JK)=PAER(JL,JK,6) ENDDO ENDDO ENDIF !* 2.2 HALF-LEVEL QUANTITIES DO JK=2,KLEV DO JL=IBEG,IEND PTH(JL,JK)=& & (PT(JL,JK-1)*PAPRSF(JL,JK-1)*(PAPRSF(JL,JK)-PAPRS(JL,JK))& & +PT(JL,JK)*PAPRSF(JL,JK)*(PAPRS(JL,JK)-PAPRSF(JL,JK-1)))& & *(1.0_JPRB/(PAPRS(JL,JK)*(PAPRSF(JL,JK)-PAPRSF(JL,JK-1)))) ENDDO ENDDO !* 2.3 QUANTITIES AT BOUNDARIES DO JL=IBEG,IEND PTH(JL,KLEV+1)=PTS(JL) PTH(JL,1)=PT(JL,1)-PAPRSF(JL,1)*(PT(JL,1)-PTH(JL,2))& & /(PAPRSF(JL,1)-PAPRS(JL,2)) ZNBAS(JL)=1. ZNTOP(JL)=1. ZCCNL(JL)=RCCNLND ZCCNO(JL)=RCCNSEA ENDDO !* 3.1 SOLAR ZENITH ANGLE IS EARTH'S CURVATURE ! CORRECTED ! CCMVAL: on impose ZRMU0=PMU0 MPL 25032010 ! 2eme essai en 3D MPL 20052010 !DO JL=IBEG,IEND ! ZRMU0(JL)=PMU0(JL) !ENDDO !!!!! A REVOIR MPL 20091201: enleve cette correction pour comparer a AR4 DO JL=IBEG,IEND IF (PMU0(JL) > 1.E-10_JPRB) THEN ZRMU0(JL)=RRAE/(SQRT(PMU0(JL)**2+ZCRAE)-PMU0(JL)) ELSE ZRMU0(JL)= RRAE/SQRT(ZCRAE) ENDIF ! print *,'RECMWF CURV: JL PMU0, ZRMU0',JL,PMU0(JL),ZRMU0(JL) ENDDO !* 4.1 CALL TO ACTUAL RADIATION SCHEME !print *,'+++++ DANS RADLSW, LRDUST ',LRDUST !WRITE(*,'("PPIZA_DST=",10E12.5)') (PPIZA_DST(1,JK,1),JK=1,KLEV) !WRITE(*,'("PCGA_DST= ",10E12.5)') (PCGA_DST(1,JK,1),JK=1,KLEV) !WRITE(*,'("PTAUREL_DST=",10E12.5)') (PTAUREL_DST(1,JK,1),JK=1,KLEV) CALL RADLSW (& & IBEG , IEND , KPROMA , KLEV , KMODE , NAER,& & ZRII0 ,& & ZRAER , PALBD , PALBP , PAPRS , ZRPR ,& & ZCCNL , ZCCNO ,& & PCCO2 , ZRCLC , PDP , PEMIS , ZEMIW ,PSLM , ZRMU0 , ZPQO3,& & ZQ , ZQIWP , ZQLWP , ZQS , ZQRAIN,ZQRAINT ,& & PTH , ZRTI , PTS , ZNBAS , ZNTOP ,& & PREF_LIQ, PREF_ICE,& & ZEMIT , ZFCT , ZFLT , ZFCS , ZFLS ,& & ZFRSOD, ZSUDU , ZUVDF , ZPARF , ZPARCF, ZTINCF, PSFSWDIR,& & PSFSWDIF,PFSDNN, PFSDNV ,& & LRDUST,PPIZA_DST,PCGA_DST,PTAUREL_DST,PFLUX,PFLUC,& & PFSDN , PFSUP , PFSCDN , PFSCUP ) !* 4.2 TRANSFORM FLUXES TO MODEL HISTORICAL VARIABLES DO JK=1,KLEV+1 DO JL=IBEG,IEND PSWFT(JL,JK)=ZFLS(JL,JK)/(ZRII0*ZRMU0(JL)) PLWFT(JL,JK)=ZFLT(JL,JK) ENDDO ENDDO ZEMTD=PLWFT ZEMTU=PLWFT DO JL=IBEG,IEND ZTRSOC(JL, 1)=ZFCS(JL, 1)/(ZRII0*ZRMU0(JL)) ZTRSOC(JL, 2)=ZFCS(JL,KLEV+1)/(ZRII0*ZRMU0(JL)) ZEMTC (JL, 1)=ZFCT(JL, 1) ZEMTC (JL, 2)=ZFCT(JL,KLEV+1) ENDDO ! ------------ -- ------- -- ---- ----- !* 5.1 STORAGE OF TRANSMISSIVITY AND EMISSIVITIES !* IN KPROMA-LONG ARRAYS DO JK=1,KLEV+1 DO JL=IBEG,IEND PEMTD(JL,JK)=ZEMTD(JL,JK) PEMTU(JL,JK)=ZEMTU(JL,JK) PTRSO(JL,JK)=MAX(0.0_JPRB,MIN(1.0_JPRB,PSWFT(JL,JK))) ENDDO ENDDO DO JK=1,2 DO JL=IBEG,IEND PCEMTR(JL,JK)=ZEMTC (JL,JK) PCTRSO(JL,JK)=MAX( 0.0_JPRB,MIN(1.0_JPRB,ZTRSOC(JL,JK))) ENDDO ENDDO DO JL=IBEG,IEND PTRSOD(JL)=MAX(0.0_JPRB,MIN(1.0_JPRB,ZFRSOD(JL)/(ZRII0*ZRMU0(JL)))) ENDDO !* 7.3 RECONSTRUCT FLUXES FOR DIAGNOSTICS DO JL=IBEG,IEND IF (PMU0(JL) < 1.E-10_JPRB) ZRMU0(JL)=0.0_JPRB ENDDO DO JK=1,KLEV+1 DO JL=IBEG,IEND PLWFT(JL,JK)=PEMTD(JL,JK) PSWFT(JL,JK)=ZRMU0(JL)*ZRII0*PTRSO(JL,JK) ENDDO ENDDO DO JK=1,2 DO JL=IBEG,IEND PSWFC(JL,JK)=ZRMU0(JL)*ZRII0*PCTRSO(JL,JK) PLWFC(JL,JK)=PCEMTR(JL,JK) ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('RECMWF',1,ZHOOK_HANDLE) END SUBROUTINE RECMWF