SUBROUTINE LWVD & &( KIDIA, KFDIA, KLON , KLEV , KTRAER & &, PABCU, PDBDT & &, PGA , PGB & &, PCNTRB, PDISD, PDISU, PDWFSU & &) !**** *LWVD* - L.W., VERTICAL INTEGRATION, DISTANT LAYERS ! PURPOSE. ! -------- ! CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS !** INTERFACE. ! ---------- ! EXPLICIT ARGUMENTS : ! -------------------- ! ==== INPUTS === ! PABCU : (KLON,NUA,3*KLEV+1) ; ABSORBER AMOUNTS ! PDBDT : (KLON,KLEV) ; LAYER PLANCK FUNCTION GRADIENT ! PGA, PGB ; PADE APPROXIMANTS ! ==== OUTPUTS === ! PCNTRB : (KLON,KLEV+1,KLEV+1); ENERGY EXCHANGE MATRIX ! PDIS.. : (KLON,KLEV+1) ; CONTRIBUTION BY DISTANT LAYERS ! PDWFSU : (KLON,NSIL) ; SPECTRAL DOWNWARD FLUX AT SURFACE ! IMPLICIT ARGUMENTS : NONE ! -------------------- ! METHOD. ! ------- ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE ! CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE ! EXTERNALS. ! ---------- ! *LWTT* ! REFERENCE. ! ---------- ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS ! AUTHOR. ! ------- ! JEAN-JACQUES MORCRETTE *ECMWF* ! MODIFICATIONS. ! -------------- ! ORIGINAL : 89-07-14 ! JJ Morcrette 97-04-18 Revised continuum + Surf. Emissiv. !----------------------------------------------------------------------- #include "tsmbkind.h" USE YOELW , ONLY : NSIL ,NIPD ,NTRA ,NUA ,NG1P1 IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER_M :: KFDIA INTEGER_M :: KIDIA INTEGER_M :: KLEV INTEGER_M :: KLON INTEGER_M :: KTRAER !----------------------------------------------------------------------- !* 0.1 ARGUMENTS ! --------- REAL_B :: PABCU(KLON,NUA,3*KLEV+1)& &, PDBDT(KLON,NSIL,KLEV)& &, PGA(KLON,NIPD,2,KLEV) , PGB(KLON,NIPD,2,KLEV) REAL_B :: PCNTRB(KLON,KLEV+1,KLEV+1)& &, PDISD(KLON,KLEV+1) , PDISU(KLON,KLEV+1)& &, PDWFSU(KLON,NSIL) !----------------------------------------------------------------------- !* 0.2 LOCAL ARRAYS ! ------------ REAL_B :: ZTT(KLON,NTRA), ZTT1(KLON,NTRA), ZTT2(KLON,NTRA) ! LOCAL INTEGER SCALARS INTEGER_M :: IJKL, IKD1, IKD2, IKJ, IKJP1, IKM1, IKN,& &IKP1, IKU1, IKU2, ITT, JA, JK, JKJ, JL, JLK ! LOCAL REAL SCALARS REAL_B :: ZWW, ZWW1, ZWW2, ZWW3, ZWW4, ZWW5, ZWW6 !----------------------------------------------------------------------- !* 1. INITIALIZATION ! -------------- !* 1.1 INITIALIZE LAYER CONTRIBUTIONS ! ------------------------------ DO JK = 1, KLEV+1 DO JL = KIDIA,KFDIA PDISD(JL,JK) = _ZERO_ PDISU(JL,JK) = _ZERO_ ENDDO ENDDO !* 1.2 INITIALIZE TRANSMISSION FUNCTIONS ! --------------------------------- DO JA = 1, NTRA DO JL = KIDIA,KFDIA ZTT (JL,JA) = _ONE_ ZTT1(JL,JA) = _ONE_ ZTT2(JL,JA) = _ONE_ ENDDO ENDDO ! ------------------------------------------------------------------ !* 2. VERTICAL INTEGRATION ! -------------------- !* 2.2 CONTRIBUTION FROM DISTANT LAYERS ! --------------------------------- !* 2.2.1 DISTANT AND ABOVE LAYERS ! ------------------------ !* 2.2.2 FIRST UPPER LEVEL ! ----------------- DO JK = 1 , KLEV-1 IKP1=JK+1 IKN=(JK-1)*NG1P1+1 IKD1= JK *NG1P1+1 CALL LWTTM & &( KIDIA , KFDIA , KLON & &, PGA(1,1,1,JK) , PGB(1,1,1,JK)& &, PABCU(1,1,IKN), PABCU(1,1,IKD1), ZTT1 & &) !* 2.2.3 HIGHER UP ! --------- ITT=1 DO JKJ=IKP1,KLEV IF(ITT == 1) THEN ITT=2 ELSE ITT=1 ENDIF IKJP1=JKJ+1 IKD2= JKJ *NG1P1+1 IF(ITT == 1) THEN CALL LWTTM & &( KIDIA , KFDIA , KLON & &, PGA(1,1,1,JKJ), PGB(1,1,1,JKJ)& &, PABCU(1,1,IKN), PABCU(1,1,IKD2), ZTT1 & &) ELSE CALL LWTTM & &( KIDIA , KFDIA , KLON & &, PGA(1,1,1,JKJ), PGB(1,1,1,JKJ)& &, PABCU(1,1,IKN), PABCU(1,1,IKD2), ZTT2 & &) ENDIF DO JA = 1, KTRAER DO JL = KIDIA,KFDIA ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*_HALF_ ENDDO ENDDO DO JL = KIDIA,KFDIA ZWW1=PDBDT(JL,1,JKJ)*ZTT(JL,1) *ZTT(JL,10) ZWW2=PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) ZWW3=PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) ZWW4=PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) ZWW5=PDBDT(JL,5,JKJ)*ZTT(JL,3) *ZTT(JL,14) ZWW6=PDBDT(JL,6,JKJ)*ZTT(JL,6) *ZTT(JL,15) ZWW=ZWW1+ZWW2+ZWW3+ZWW4+ZWW5+ZWW6 PDISD(JL,JK)=PDISD(JL,JK)+ZWW PCNTRB(JL,JK,IKJP1)=ZWW IF (JK == 1) THEN PDWFSU(JL,1)=PDWFSU(JL,1)+ZWW1 PDWFSU(JL,2)=PDWFSU(JL,2)+ZWW2 PDWFSU(JL,3)=PDWFSU(JL,3)+ZWW3 PDWFSU(JL,4)=PDWFSU(JL,4)+ZWW4 PDWFSU(JL,5)=PDWFSU(JL,5)+ZWW5 PDWFSU(JL,6)=PDWFSU(JL,6)+ZWW6 ENDIF ENDDO ENDDO ENDDO !* 2.2.4 DISTANT AND BELOW LAYERS ! ------------------------ !* 2.2.5 FIRST LOWER LEVEL ! ----------------- DO JK=3,KLEV+1 IKN=(JK-1)*NG1P1+1 IKM1=JK-1 IKJ=JK-2 IKU1= IKJ *NG1P1+1 CALL LWTTM & &( KIDIA , KFDIA , KLON & &, PGA(1,1,1,IKJ) , PGB(1,1,1,IKJ)& &, PABCU(1,1,IKU1), PABCU(1,1,IKN), ZTT1 & &) !* 2.2.6 DOWN BELOW ! ---------- ITT=1 DO JLK=1,IKJ IF(ITT == 1) THEN ITT=2 ELSE ITT=1 ENDIF IJKL=IKM1-JLK IKU2=(IJKL-1)*NG1P1+1 IF(ITT == 1) THEN CALL LWTTM & &( KIDIA , KFDIA , KLON & &, PGA(1,1,1,IJKL), PGB(1,1,1,IJKL)& &, PABCU(1,1,IKU2), PABCU(1,1,IKN) , ZTT1 & &) ELSE CALL LWTTM & &( KIDIA , KFDIA , KLON & &, PGA(1,1,1,IJKL), PGB(1,1,1,IJKL)& &, PABCU(1,1,IKU2), PABCU(1,1,IKN) , ZTT2 & &) ENDIF DO JA = 1, KTRAER DO JL = KIDIA,KFDIA ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*_HALF_ ENDDO ENDDO DO JL = KIDIA,KFDIA ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1) *ZTT(JL,10)& &+PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)& &+PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)& &+PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)& &+PDBDT(JL,5,IJKL)*ZTT(JL,3) *ZTT(JL,14)& &+PDBDT(JL,6,IJKL)*ZTT(JL,6) *ZTT(JL,15) PDISU(JL,JK)=PDISU(JL,JK)+ZWW PCNTRB(JL,JK,IJKL)=ZWW ENDDO ENDDO ENDDO ! ------------------------------------------------------------------ RETURN END SUBROUTINE LWVD