--- trunk/libf/phylmd/Radlwsw/swtt.f 2010/03/03 13:23:49 24 +++ trunk/phylmd/Radlwsw/swtt.f 2018/03/20 09:35:59 265 @@ -1,116 +1,104 @@ - SUBROUTINE SWTT (KNU,KA,PU,PTR) - use dimens_m - use dimphy - use raddim - IMPLICIT none -C -C----------------------------------------------------------------------- -C PURPOSE. -C -------- -C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE -C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL -C INTERVALS. -C -C METHOD. -C ------- -C -C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS -C AND HORNER'S ALGORITHM. -C -C REFERENCE. -C ---------- -C -C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND -C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS -C -C AUTHOR. -C ------- -C JEAN-JACQUES MORCRETTE *ECMWF* -C -C MODIFICATIONS. -C -------------- -C ORIGINAL : 88-12-15 -C----------------------------------------------------------------------- -C -C* ARGUMENTS -C - INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL - INTEGER KA ! INDEX OF THE ABSORBER - REAL*8 PU(KDLON) ! ABSORBER AMOUNT -C - REAL*8 PTR(KDLON) ! TRANSMISSION FUNCTION -C -C* LOCAL VARIABLES: -C - REAL*8 ZR1(KDLON), ZR2(KDLON) - INTEGER jl, i,j -C -C* Prescribed Data: -C - REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3) - SAVE APAD, BPAD, D - DATA ((APAD(1,I,J),I=1,3),J=1,7) / - S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04, - S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01, - S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00, - S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02, - S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02, - S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02, - S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 / - DATA ((APAD(2,I,J),I=1,3),J=1,7) / - S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03, - S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02, - S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00, - S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00, - S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00, - S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00, - S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 / -C - DATA ((BPAD(1,I,J),I=1,3),J=1,7) / - S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04, - S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01, - S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00, - S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02, - S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02, - S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02, - S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 / - DATA ((BPAD(2,I,J),I=1,3),J=1,7) / - S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03, - S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02, - S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01, - S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00, - S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00, - S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00, - S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 / -c - DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 / - DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 / -C -C----------------------------------------------------------------------- -C -C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION -C - 100 CONTINUE -C - DO 201 JL = 1, KDLON - ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL) - S * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL) - S * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL) - S * ( APAD(KNU,KA,7) )))))) -C - ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL) - S * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL) - S * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL) - S * ( BPAD(KNU,KA,7) )))))) -C -C -C* 2. ADD THE BACKGROUND TRANSMISSION -C - 200 CONTINUE -C -C - PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA) - 201 CONTINUE -C - RETURN - END +SUBROUTINE swtt(knu, ka, pu, ptr) + USE dimensions + USE dimphy + USE raddim + IMPLICIT NONE + + ! ----------------------------------------------------------------------- + ! PURPOSE. + ! -------- + ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE + ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL + ! INTERVALS. + + ! METHOD. + ! ------- + + ! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS + ! AND HORNER'S ALGORITHM. + + ! 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 : 88-12-15 + ! ----------------------------------------------------------------------- + + ! * ARGUMENTS + + INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL + INTEGER ka ! INDEX OF THE ABSORBER + DOUBLE PRECISION pu(kdlon) ! ABSORBER AMOUNT + + DOUBLE PRECISION ptr(kdlon) ! TRANSMISSION FUNCTION + + ! * LOCAL VARIABLES: + + DOUBLE PRECISION zr1(kdlon), zr2(kdlon) + INTEGER jl, i, j + + ! * Prescribed Data: + + DOUBLE PRECISION apad(2, 3, 7), bpad(2, 3, 7), d(2, 3) + SAVE apad, bpad, d + DATA ((apad(1,i,j),i=1,3), j=1, 7)/0.912418292D+05, 0.000000000D-00, & + 0.925887084D-04, 0.723613782D+05, 0.000000000D-00, 0.129353723D-01, & + 0.596037057D+04, 0.000000000D-00, 0.800821928D+00, 0.000000000D-00, & + 0.000000000D-00, 0.242715973D+02, 0.000000000D-00, 0.000000000D-00, & + 0.878331486D+02, 0.000000000D-00, 0.000000000D-00, 0.191559725D+02, & + 0.000000000D-00, 0.000000000D-00, 0.000000000D+00/ + DATA ((apad(2,i,j),i=1,3), j=1, 7)/0.376655383D-08, 0.739646016D-08, & + 0.410177786D+03, 0.978576773D-04, 0.131849595D-03, 0.672595424D+02, & + 0.387714006D+00, 0.437772681D+00, 0.000000000D-00, 0.118461660D+03, & + 0.151345118D+03, 0.000000000D-00, 0.119079797D+04, 0.233628890D+04, & + 0.000000000D-00, 0.293353397D+03, 0.797219934D+03, 0.000000000D-00, & + 0.000000000D+00, 0.000000000D+00, 0.000000000D+00/ + + DATA ((bpad(1,i,j),i=1,3), j=1, 7)/0.912418292D+05, 0.000000000D-00, & + 0.925887084D-04, 0.724555318D+05, 0.000000000D-00, 0.131812683D-01, & + 0.602593328D+04, 0.000000000D-00, 0.812706117D+00, 0.100000000D+01, & + 0.000000000D-00, 0.249863591D+02, 0.000000000D-00, 0.000000000D-00, & + 0.931071925D+02, 0.000000000D-00, 0.000000000D-00, 0.252233437D+02, & + 0.000000000D-00, 0.000000000D-00, 0.100000000D+01/ + DATA ((bpad(2,i,j),i=1,3), j=1, 7)/0.376655383D-08, 0.739646016D-08, & + 0.410177786D+03, 0.979023421D-04, 0.131861712D-03, 0.731185438D+02, & + 0.388611139D+00, 0.437949001D+00, 0.100000000D+01, 0.120291383D+03, & + 0.151692730D+03, 0.000000000D+00, 0.130531005D+04, 0.237071130D+04, & + 0.000000000D+00, 0.415049409D+03, 0.867914360D+03, 0.000000000D+00, & + 0.100000000D+01, 0.100000000D+01, 0.000000000D+00/ + + DATA (d(1,i), i=1, 3)/0.00d0, 0.00d0, 0.00d0/ + DATA (d(2,i), i=1, 3)/0.000000000d0, 0.000000000d0, 0.800000000d0/ + + ! ----------------------------------------------------------------------- + + ! * 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION + + + DO jl = 1, kdlon + zr1(jl) = apad(knu, ka, 1) + pu(jl)*(apad(knu,ka,2)+pu(jl)*(apad(knu,ka, & + 3)+pu(jl)*(apad(knu,ka,4)+pu(jl)*(apad(knu,ka,5)+pu(jl)*(apad(knu,ka,6) & + +pu(jl)*(apad(knu,ka,7))))))) + + zr2(jl) = bpad(knu, ka, 1) + pu(jl)*(bpad(knu,ka,2)+pu(jl)*(bpad(knu,ka, & + 3)+pu(jl)*(bpad(knu,ka,4)+pu(jl)*(bpad(knu,ka,5)+pu(jl)*(bpad(knu,ka,6) & + +pu(jl)*(bpad(knu,ka,7))))))) + + + ! * 2. ADD THE BACKGROUND TRANSMISSION + + + + ptr(jl) = (zr1(jl)/zr2(jl))*(1.-d(knu,ka)) + d(knu, ka) + END DO + + RETURN +END SUBROUTINE swtt