--- trunk/phylmd/Radlwsw/swtt1.f 2014/03/05 12:22:46 80 +++ trunk/phylmd/Radlwsw/swtt1.f90 2014/03/05 14:38:41 81 @@ -1,120 +1,108 @@ - SUBROUTINE SWTT1(KNU,KABS,KIND, 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 : 95-01-20 -C----------------------------------------------------------------------- -C* ARGUMENTS: -C - INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL - INTEGER KABS ! NUMBER OF ABSORBERS - INTEGER KIND(KABS) ! INDICES OF THE ABSORBERS - DOUBLE PRECISION PU(KDLON,KABS) ! ABSORBER AMOUNT -C - DOUBLE PRECISION PTR(KDLON,KABS) ! TRANSMISSION FUNCTION -C -C* LOCAL VARIABLES: -C - DOUBLE PRECISION ZR1(KDLON) - DOUBLE PRECISION ZR2(KDLON) - DOUBLE PRECISION ZU(KDLON) - INTEGER jl, ja, i, j, ia -C -C* Prescribed Data: -C - 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) / - 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* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION -C - 100 CONTINUE -C - DO 202 JA = 1,KABS - IA=KIND(JA) - DO 201 JL = 1, KDLON - ZU(JL) = PU(JL,JA) - ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL) - S * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL) - S * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL) - S * ( APAD(KNU,IA,7) )))))) -C - ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL) - S * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL) - S * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL) - S * ( BPAD(KNU,IA,7) )))))) -C -C -C* 2. ADD THE BACKGROUND TRANSMISSION -C - 200 CONTINUE -C - PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA) - 201 CONTINUE - 202 CONTINUE -C - RETURN - END +SUBROUTINE swtt1(knu, kabs, kind, pu, ptr) + USE dimens_m + 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 : 95-01-20 + ! ----------------------------------------------------------------------- + ! * ARGUMENTS: + + INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL + INTEGER kabs ! NUMBER OF ABSORBERS + INTEGER kind(kabs) ! INDICES OF THE ABSORBERS + DOUBLE PRECISION pu(kdlon, kabs) ! ABSORBER AMOUNT + + DOUBLE PRECISION ptr(kdlon, kabs) ! TRANSMISSION FUNCTION + + ! * LOCAL VARIABLES: + + DOUBLE PRECISION zr1(kdlon) + DOUBLE PRECISION zr2(kdlon) + DOUBLE PRECISION zu(kdlon) + INTEGER jl, ja, i, j, ia + + ! * 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.912418292E+05, 0.000000000E-00, & + 0.925887084E-04, 0.723613782E+05, 0.000000000E-00, 0.129353723E-01, & + 0.596037057E+04, 0.000000000E-00, 0.800821928E+00, 0.000000000E-00, & + 0.000000000E-00, 0.242715973E+02, 0.000000000E-00, 0.000000000E-00, & + 0.878331486E+02, 0.000000000E-00, 0.000000000E-00, 0.191559725E+02, & + 0.000000000E-00, 0.000000000E-00, 0.000000000E+00/ + DATA ((apad(2,i,j),i=1,3), j=1, 7)/0.376655383E-08, 0.739646016E-08, & + 0.410177786E+03, 0.978576773E-04, 0.131849595E-03, 0.672595424E+02, & + 0.387714006E+00, 0.437772681E+00, 0.000000000E-00, 0.118461660E+03, & + 0.151345118E+03, 0.000000000E-00, 0.119079797E+04, 0.233628890E+04, & + 0.000000000E-00, 0.293353397E+03, 0.797219934E+03, 0.000000000E-00, & + 0.000000000E+00, 0.000000000E+00, 0.000000000E+00/ + + DATA ((bpad(1,i,j),i=1,3), j=1, 7)/0.912418292E+05, 0.000000000E-00, & + 0.925887084E-04, 0.724555318E+05, 0.000000000E-00, 0.131812683E-01, & + 0.602593328E+04, 0.000000000E-00, 0.812706117E+00, 0.100000000E+01, & + 0.000000000E-00, 0.249863591E+02, 0.000000000E-00, 0.000000000E-00, & + 0.931071925E+02, 0.000000000E-00, 0.000000000E-00, 0.252233437E+02, & + 0.000000000E-00, 0.000000000E-00, 0.100000000E+01/ + DATA ((bpad(2,i,j),i=1,3), j=1, 7)/0.376655383E-08, 0.739646016E-08, & + 0.410177786E+03, 0.979023421E-04, 0.131861712E-03, 0.731185438E+02, & + 0.388611139E+00, 0.437949001E+00, 0.100000000E+01, 0.120291383E+03, & + 0.151692730E+03, 0.000000000E+00, 0.130531005E+04, 0.237071130E+04, & + 0.000000000E+00, 0.415049409E+03, 0.867914360E+03, 0.000000000E+00, & + 0.100000000E+01, 0.100000000E+01, 0.000000000E+00/ + + 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/ + ! ----------------------------------------------------------------------- + + ! * 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION + + + DO ja = 1, kabs + ia = kind(ja) + DO jl = 1, kdlon + zu(jl) = pu(jl, ja) + zr1(jl) = apad(knu, ia, 1) + zu(jl)*(apad(knu,ia,2)+zu(jl)*(apad(knu, & + ia,3)+zu(jl)*(apad(knu,ia,4)+zu(jl)*(apad(knu,ia,5)+zu(jl)*(apad(knu, & + ia,6)+zu(jl)*(apad(knu,ia,7))))))) + + zr2(jl) = bpad(knu, ia, 1) + zu(jl)*(bpad(knu,ia,2)+zu(jl)*(bpad(knu, & + ia,3)+zu(jl)*(bpad(knu,ia,4)+zu(jl)*(bpad(knu,ia,5)+zu(jl)*(bpad(knu, & + ia,6)+zu(jl)*(bpad(knu,ia,7))))))) + + + ! * 2. ADD THE BACKGROUND TRANSMISSION + + + ptr(jl, ja) = (zr1(jl)/zr2(jl))*(1.-d(knu,ia)) + d(knu, ia) + END DO + END DO + + RETURN +END SUBROUTINE swtt1