SUBROUTINE TABLE !>-------------------------------------------------------------------------------------------------- !> SUBROUTINE TABLE !> !> SUBPROGRAM: TABLE - COMPUTES TABLE ENTRIES USED IN THE LONGWAVE RADIA PROGRAM !> PROGRAMMER: ????? !> ORG: ????? !> DATE: ??-??-?? !> !> ABSTRACT: !> SUBROUTINE TABLE COMPUTES TABLE ENTRIES USED IN THE LONGWAVE RADIA PROGRAM. ALSO CALCULATED ARE !> INDICES USED IN STRIP-MINING AND FOR SOME PRE-COMPUTABLE FUNCTIONS. !> !> PROGRAM HISTORY LOG: !> ??-??-?? ????? - ORIGINATOR !> 18-01-15 LUCCI - MODERNIZATION OF THE CODE, INCLUDING: !> * F77 TO F90/F95 !> * INDENTATION & UNIFORMIZATION CODE !> * REPLACEMENT OF COMMONS BLOCK FOR MODULES !> * DOCUMENTATION WITH DOXYGEN !> * OPENMP FUNCTIONALITY !> !> INPUT ARGUMENT LIST: !> NONE !> !> OUTPUT ARGUMENT LIST: !> NONE !> !> INPUT/OUTPUT ARGUMENT LIST: !> !> USE MODULES: F77KINDS !> GLB_TABLE !> HCON !> MAPPINGS !> MPPCOM !> PARMETA !> PHYCON !> RNDDTA !> SCRTCH !> TABCOM !> TBLTMP !> TEMPCOM !> TOPO !> !> DRIVER : CONRAD !> !> CALLS : ----- !>-------------------------------------------------------------------------------------------------- USE F77KINDS USE GLB_TABLE USE HCON USE MAPPINGS USE MPPCOM USE PARMETA USE PHYCON USE RNDDTA USE SCRTCH USE TABCOM USE TBLTMP USE TEMPCOM USE TOPO ! IMPLICIT NONE ! #include "sp.h" !------------------------------------------------------------------------------------------ ! PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: ! IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. ! L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL ! NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS ! NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE BANDTA FOR DEFINITION ! NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS ! NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE BDCOMB FOR DEFINITION ! INLTE = NO. LEVELS USED FOR NLTE CALCS. ! NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. ! NB, KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED FROM THE ABOVE PARAMETERS. !------------------------------------------------------------------------------------------ INTEGER(KIND=I4KIND), PARAMETER :: L = LM INTEGER(KIND=I4KIND), PARAMETER :: NCOL = IMAX INTEGER(KIND=I4KIND), PARAMETER :: NBLM = NBLY - 1 INTEGER(KIND=I4KIND), PARAMETER :: LP2 = L + 2 INTEGER(KIND=I4KIND), PARAMETER :: LP3 = L + 3 INTEGER(KIND=I4KIND), PARAMETER :: LM1 = L - 1 INTEGER(KIND=I4KIND), PARAMETER :: LM2 = L - 2 INTEGER(KIND=I4KIND), PARAMETER :: LM3 = L - 3 INTEGER(KIND=I4KIND), PARAMETER :: LL = 2 * L INTEGER(KIND=I4KIND), PARAMETER :: LLP1 = LL + 1 INTEGER(KIND=I4KIND), PARAMETER :: LLP2 = LL + 2 INTEGER(KIND=I4KIND), PARAMETER :: LLP3 = LL + 3 INTEGER(KIND=I4KIND), PARAMETER :: LLM1 = LL - 1 INTEGER(KIND=I4KIND), PARAMETER :: LLM2 = LL - 2 INTEGER(KIND=I4KIND), PARAMETER :: LLM3 = LL - 3 INTEGER(KIND=I4KIND), PARAMETER :: LP1M = LP1 * LP1 INTEGER(KIND=I4KIND), PARAMETER :: LP1M1 = LP1M - 1 INTEGER(KIND=I4KIND), PARAMETER :: LP121 = LP1 * NBLY INTEGER(KIND=I4KIND), PARAMETER :: LL3P = 3 * L + 2 INTEGER(KIND=I4KIND), PARAMETER :: NB = 12 INTEGER(KIND=I4KIND), PARAMETER :: INLTE = 3 INTEGER(KIND=I4KIND), PARAMETER :: INLTEP = INLTE + 1 INTEGER(KIND=I4KIND), PARAMETER :: NNLTE = 56 INTEGER(KIND=I4KIND), PARAMETER :: LP1I = IMAX * LP1 INTEGER(KIND=I4KIND), PARAMETER :: LLP1I = IMAX * LLP1 INTEGER(KIND=I4KIND), PARAMETER :: LL3PI = IMAX * LL3P INTEGER(KIND=I4KIND), PARAMETER :: NB1 = NB - 1 INTEGER(KIND=I4KIND), PARAMETER :: KO2 = 12 INTEGER(KIND=I4KIND), PARAMETER :: KO21 = KO2 + 1 INTEGER(KIND=I4KIND), PARAMETER :: KO2M = KO2 - 1 !------------------------ ! IMPLICIT NONE VARIABLES !------------------------ INTEGER(KIND=I4KIND) ::& & I , N , ICNT , I1 , I2 , I2E , J , JP , IA , & & NSB , NSUBDS ! REAL (KIND=R4KIND) ::& & CENT , DEL , BDLO , BDHI , ANU , C1 !-------------------------------------------------------------- ! COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15 FOR NARROW-BANDS... !-------------------------------------------------------------- DO 101 N=1,NBLW ANB(N) = ARNDM(N) BNB(N) = BRNDM(N) CENTNB(N) = HAF * (BANDLO(N) + BANDHI(N)) DELNB(N) = BANDHI(N) - BANDLO(N) BETANB(N) = BETAD(N) 101 END DO ! AB15(1) = ANB(57) * BNB(57) AB15(2) = ANB(58) * BNB(58) !------------------ ! FOR WIDE BANDS... !------------------ AB15WD = AWIDE * BWIDE !--------------------------------- ! COMPUTE INDICES: IND,INDX2,KMAXV !--------------------------------- DO 111 I=1,IMAX IND(I) = I 111 END DO ! ICNT = 0 ! DO 113 I1=1,L I2E = LP1 - I1 DO 115 I2=1,I2E ICNT = ICNT + 1 INDX2(ICNT) = LP1 * (I2 - 1) + LP2 * I1 115 END DO 113 END DO ! KMAXV(1) = 1 ! DO 117 I=2,L KMAXV(I) = KMAXV(I-1) + (LP2-I) 117 END DO ! KMAXVM = KMAXV(L) !------------------------------- ! COMPUTE RATIOS OF CONT. COEFFS !--------------------------------- SKC1R = BETAWD / BETINW SKO3R = BETAD(61) / BETINW SKO2D = ONE / BETINW !-------------------------------------------------------------------------------------------------- ! BEGIN TABLE COMPUTATIONS HERE ! COMPUTE TEMPS, MASSES FOR TABLE ENTRIES ! NOTE: THE DIMENSIONING AND INITIALIZATION OF XTEMV AND OTHER ARRAYS WITH DIMENSION OF 28 IMPLY ! A RESTRICTION OF MODEL TEMPERATURES FROM 100K TO 370K. ! THE DIMENSIONING OF ZMASS,ZROOT AND OTHER ARRAYS WITH DIMENSION OF 180 IMPLY A RESTRICTION OF ! MODEL H2O AMOUNTS SUCH THAT OPTICAL PATHS ARE BETWEEN 10**-16 AND 10**2, IN CGS UNITS. !-------------------------------------------------------------------------------------------------- ZMASS(1) = H1M16 ! DO 201 J=1,180 JP = J+1 ZROOT(J) = SQRT(ZMASS(J)) ZMASS(JP) = ZMASS(J) * H1P25892 201 END DO ! DO 203 I=1,28 XTEMV(I) = HNINETY + TEN * I TFOUR(I) = XTEMV(I) * XTEMV(I) * XTEMV(I) * XTEMV(I) FORTCU(I) = FOUR * XTEMV(I) * XTEMV(I) * XTEMV(I) 203 END DO !------------------------------------------------------------------------------------------------------------------------------- ! THE COMPUTATION OF SOURCE,DSRCE IS NEEDED ONLY FOR THE COMBINED WIDE-BAND CASE.TO OBTAIN THEM, THE SOURCE MUST BE COMPUTED FOR ! EACH OF THE (NBLX) WIDE BANDS(=SRCWD) THEN COMBINED (USING IBAND) INTO SOURCE. !------------------------------------------------------------------------------------------------------------------------------- DO 205 N=1,NBLY DO 205 I=1,28 SOURCE(I,N) = ZERO 205 END DO ! DO 207 N=1,NBLX DO 207 I=1,28 SRCWD(I,N) = ZERO 207 END DO !------------------------ ! BEGIN FREQ. LOOP (ON N) !------------------------ DO 211 N=1,NBLX IF (N <= 46) THEN !------------------------ ! THE 160-1200 BAND CASES !------------------------ CENT = CENTNB(N+16) DEL = DELNB(N+16) BDLO = BANDLO(N+16) BDHI = BANDHI(N+16) END IF ! IF (N == NBLX) THEN !------------------------ ! THE 2270-2380 BAND CASE !------------------------ CENT = CENTNB(NBLW) DEL = DELNB(NBLW) BDLO = BANDLO(NBLW) BDHI = BANDHI(NBLW) END IF !--------------------------------------------------------------------------------------------------------------------------------- ! FOR PURPOSES OF ACCURACY, ALL EVALUATIONS OF PLANCK FCTNS ARE MADE ON 10 CM-1 INTERVALS, THEN SUMMED INTO THE (NBLX) WIDE BANDS. !--------------------------------------------------------------------------------------------------------------------------------- NSUBDS = (DEL - H1M3) / 10 + 1 ! DO 213 NSB=1,NSUBDS IF (NSB /= NSUBDS) THEN CNUSB(NSB) = TEN * (NSB-1) + BDLO + FIVE DNUSB(NSB) = TEN ELSE CNUSB(NSB) = HAF * (TEN*(NSB-1) + BDLO + BDHI) DNUSB(NSB) = BDHI - (TEN * (NSB-1) + BDLO) END IF ! C1 = (H37412M5) * CNUSB(NSB) ** 3 !------------------------ ! BEGIN TEMP. LOOP (ON I) !------------------------ DO 215 I=1,28 X(I) = H1P4387 * CNUSB(NSB) / XTEMV(I) X1(I) = EXP(X(I)) SRCS(I) = C1 / (X1(I) - ONE) SRCWD(I,N) = SRCWD(I,N) + SRCS(I) * DNUSB(NSB) 215 END DO 213 END DO ! 211 END DO !------------------------------------------------------------------------------ ! THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE AND DSRCE !------------------------------------------------------------------------------ DO 221 N=1,40 DO 221 I=1,28 SOURCE(I,IBAND(N)) = SOURCE(I,IBAND(N)) + SRCWD(I,N) 221 END DO ! DO 223 N=9,NBLY DO 223 I=1,28 SOURCE(I,N) = SRCWD(I,N+32) 223 END DO ! DO 225 N=1,NBLY DO 225 I=1,27 DSRCE(I,N) = (SOURCE(I+1,N) - SOURCE(I,N)) * HP1 225 END DO ! DO 231 N=1,NBLW ALFANB(N) = BNB(N) * ANB(N) AROTNB(N) = SQRT(ALFANB(N)) 231 END DO !-------------------------------------------------------------------------------------------------- ! FIRST COMPUTE PLANCK FCTNS (SRC1NB) AND DERIVATIVES (DBDTNB) FOR USE IN TABLE EVALUATIONS. THESE ! ARE DIFFERENT FROM SOURCE,DSRCE BECAUSE DIFFERENT FREQUENCY PTS ARE USED IN EVALUATION, ! THE FREQ. RANGES ARE DIFFERENT, AND THE DERIVATIVE ALGORITHM IS DIFFERENT. !-------------------------------------------------------------------------------------------------- DO 301 N=1,NBLW CENT = CENTNB(N) DEL = DELNB(N) !-------------------------------------------------------------------------------------------------- ! NOTE: AT PRESENT, THE IA LOOP IS ONLY USED FOR IA=2. THE LOOP STRUCT IS KEPT SO THAT IN THE ! FUTURE, WE MAY USE A QUADRATURE SCHEME FOR THE PLANCK FCTN EVALUATION, RATHER THAN USE THE ! MID-BAND FREQUENCY. !-------------------------------------------------------------------------------------------------- DO 303 IA=1,3 ANU = CENT + HAF * (IA-2) * DEL C1 = (H37412M5) * ANU * ANU * ANU + H1M20 !----------------- ! TEMPERATURE LOOP !----------------- DO 305 I=1,28 X(I) = H1P4387 * ANU / XTEMV(I) X1(I) = EXP(X(I)) SC(I) = C1 / ((X1(I) - ONE) + H1M20) DSC(I) = SC(I) * SC(I) * X(I) * X1(I) / (XTEMV(I) *C1) 305 END DO ! IF (IA == 2) THEN DO 307 I=1,28 SRC1NB(I,N) = DEL * SC(I) DBDTNB(I,N) = DEL * DSC(I) 307 END DO END IF ! 303 END DO ! 301 END DO !-------------------------------------------------------------------------------------------------- ! NEXT COMPUTE R1,R2,S2,AND T3-COEFFICIENTS USED FOR E3 FUNCTION WHEN THE OPTICAL PATH IS LESS ! THAN 10-4. IN THIS CASE, WE ASSUME A DIFFERENT DEPENDENCE ON (ZMASS). ALSO OBTAIN R1WD, ! WHICH IS R1 SUMMED OVER THE 160-560 CM-1 RANGE !-------------------------------------------------------------------------------------------------- DO 311 I=1,28 SUM4(I) = ZERO SUM6(I) = ZERO SUM7(I) = ZERO SUM8(I) = ZERO SUM4WD(I) = ZERO 311 END DO ! DO 313 N=1,NBLW CENT = CENTNB(N) !------------------------------------------------------------------------------------- ! PERFORM SUMMATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 FOR SUM4, SUM6,SUM7,SUM8 !------------------------------------------------------------------------------------- IF (CENT < 560. .OR. CENT > 1200. .AND. CENT <= 2200.) THEN DO 315 I=1,28 SUM4(I) = SUM4(I) + SRC1NB(I,N) SUM6(I) = SUM6(I) + DBDTNB(I,N) SUM7(I) = SUM7(I) + DBDTNB(I,N) * AROTNB(N) SUM8(I) = SUM8(I) + DBDTNB(I,N) * ALFANB(N) 315 END DO END IF !---------------------------------------------------------------------- ! PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD) !---------------------------------------------------------------------- IF (CENT > 160. .AND. CENT < 560.) THEN DO 316 I=1,28 SUM4WD(I) = SUM4WD(I) + SRC1NB(I,N) 316 END DO END IF ! 313 END DO ! DO 317 I=1,28 R1(I) = SUM4(I) / TFOUR(I) R2(I) = SUM6(I) / FORTCU(I) S2(I) = SUM7(I) / FORTCU(I) T3(I) = SUM8(I) / FORTCU(I) R1WD(I) = SUM4WD(I) / TFOUR(I) 317 END DO ! DO 401 J=1,180 DO 401 I=1,28 SUM(I,J) = ZERO PERTSM(I,J) = ZERO SUM3(I,J) = ZERO SUMWDE(I,J) = ZERO 401 END DO !---------------------- ! FREQUENCY LOOP BEGINS !---------------------- DO 411 N=1,NBLW CENT = CENTNB(N) !-------------------------------------------------------------- ! PERFORM CALCULATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 !-------------------------------------------------------------- IF (CENT < 560. .OR. CENT > 1200. .AND. CENT <= 2200.) THEN DO 413 J=1,180 X2(J) = AROTNB(N) * ZROOT(J) EXPO(J) = EXP(-X2(J)) 413 END DO ! DO 415 J=1,180 IF (X2(J) >= HUNDRED) THEN EXPO(J) = ZERO END IF 415 END DO ! DO 417 J=121,180 FAC(J) = ZMASS(J) * (ONE - (ONE + X2(J)) * EXPO(J)) / (X2(J) * X2(J)) 417 END DO ! DO 419 J=1,180 DO 419 I=1,28 SUM(I,J) = SUM(I,J) + SRC1NB(I,N) * EXPO(J) PERTSM(I,J) = PERTSM(I,J) + DBDTNB(I,N) * EXPO(J) 419 END DO ! DO 421 J=121,180 DO 421 I=1,28 SUM3(I,J) = SUM3(I,J) + DBDTNB(I,N) * FAC(J) 421 END DO END IF !----------------------------------------------------------------- ! COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE) !----------------------------------------------------------------- IF (CENT > 160. .AND. CENT < 560.) THEN DO 420 J=1,180 DO 420 I=1,28 SUMWDE(I,J) = SUMWDE(I,J) + SRC1NB(I,N) * EXPO(J) 420 END DO END IF ! 411 END DO ! DO 431 J=1,180 DO 431 I=1,28 EM1(I,J) = SUM(I,J) / TFOUR(I) TABLE1(I,J) = PERTSM(I,J) / FORTCU(I) 431 END DO ! DO 433 J=121,180 DO 433 I=1,28 EM3(I,J) = SUM3(I,J) / FORTCU(I) 433 END DO ! DO 441 J=1,179 DO 441 I=1,28 TABLE2(I,J) = (TABLE1(I,J+1) - TABLE1(I,J)) * TEN 441 END DO ! DO 443 J=1,180 DO 443 I=1,27 TABLE3(I,J) = (TABLE1(I+1,J) - TABLE1(I,J)) * HP1 443 END DO ! DO 445 I=1,28 TABLE2(I,180) = ZERO 445 END DO ! DO 447 J=1,180 TABLE3(28,J) = ZERO 447 END DO ! DO 449 J=1,2 DO 449 I=1,28 EM1(I,J) = R1(I) 449 END DO ! DO 451 J=1,120 DO 451 I=1,28 EM3(I,J) = R2(I) / TWO-S2(I) * SQRT(ZMASS(J)) / THREE + T3(I) * ZMASS(J) / EIGHT 451 END DO ! DO 453 J=121,180 DO 453 I=1,28 EM3(I,J) = EM3(I,J) / ZMASS(J) 453 END DO !------------------------------------------------------------------------------------------ ! NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY. WE USE R1WD AND SUMWDE OBTAINED ABOVE. !------------------------------------------------------------------------------------------ DO 501 J=1,180 DO 501 I=1,28 EM1WDE(I,J) = SUMWDE(I,J) / TFOUR(I) 501 END DO ! DO 503 J=1,2 DO 503 I=1,28 EM1WDE(I,J) = R1WD(I) 503 END DO ! RETURN ! END SUBROUTINE TABLE