| [2089] | 1 | !*************************************************************************** |
|---|
| 2 | SUBROUTINE RRTM_INIT_140GP |
|---|
| 3 | !*************************************************************************** |
|---|
| 4 | ! Reformatted for F90 by JJMorcrette, ECMWF, 980714 |
|---|
| 5 | |
|---|
| 6 | ! Parameters |
|---|
| 7 | #include "tsmbkind.h" |
|---|
| 8 | |
|---|
| 9 | USE PARRRTM , ONLY : JPBAND ,JPG ,JPXSEC ,JPGPT |
|---|
| 10 | USE YOERRTWN , ONLY : NG ,NSPA ,NSPB |
|---|
| 11 | USE YOERRTFTR, ONLY : NGC ,NGS ,NGN ,NGB ,NGM , WT |
|---|
| 12 | ! Output |
|---|
| 13 | USE YOERRTBG2, ONLY : CORR1 ,CORR2 |
|---|
| 14 | USE YOERRTRWT, ONLY : FREFA ,FREFB ,FREFADF ,FREFBDF ,RWGT |
|---|
| 15 | |
|---|
| 16 | ! Local |
|---|
| 17 | |
|---|
| 18 | IMPLICIT NONE |
|---|
| 19 | REAL_B :: WTSM(JPG) |
|---|
| 20 | |
|---|
| 21 | ! LOCAL INTEGER SCALARS |
|---|
| 22 | INTEGER_M :: I, IBND, IG, IGC, IGCSM, IND, IPR, IPRSM, IPT |
|---|
| 23 | |
|---|
| 24 | ! LOCAL REAL SCALARS |
|---|
| 25 | REAL_B :: FP, RTFP, WTSUM |
|---|
| 26 | |
|---|
| 27 | |
|---|
| 28 | ! Calculate lookup tables for functions needed in routine TAUMOL (TAUGB2) |
|---|
| 29 | CORR1(0) = _ONE_ |
|---|
| 30 | CORR1(200) = _ONE_ |
|---|
| 31 | CORR2(0) = _ONE_ |
|---|
| 32 | CORR2(200) = _ONE_ |
|---|
| 33 | DO I = 1,199 |
|---|
| 34 | FP = 0.005_JPRB*REAL(I) |
|---|
| 35 | RTFP = SQRT(FP) |
|---|
| 36 | CORR1(I) = RTFP/FP |
|---|
| 37 | CORR2(I) = (_ONE_-RTFP)/(_ONE_-FP) |
|---|
| 38 | ENDDO |
|---|
| 39 | |
|---|
| 40 | ! Perform g-point reduction from 16 per band (256 total points) to |
|---|
| 41 | ! a band dependant number (140 total points) for all absorption |
|---|
| 42 | ! coefficient input data and Planck fraction input data. |
|---|
| 43 | ! Compute relative weighting for new g-point combinations. |
|---|
| 44 | |
|---|
| 45 | IGCSM = 0 |
|---|
| 46 | DO IBND = 1,JPBAND |
|---|
| 47 | IPRSM = 0 |
|---|
| 48 | IF (NGC(IBND) < 16) THEN |
|---|
| 49 | DO IGC = 1,NGC(IBND) |
|---|
| 50 | IGCSM = IGCSM + 1 |
|---|
| 51 | WTSUM = _ZERO_ |
|---|
| 52 | DO IPR = 1, NGN(IGCSM) |
|---|
| 53 | IPRSM = IPRSM + 1 |
|---|
| 54 | WTSUM = WTSUM + WT(IPRSM) |
|---|
| 55 | ENDDO |
|---|
| 56 | WTSM(IGC) = WTSUM |
|---|
| 57 | ENDDO |
|---|
| 58 | DO IG = 1,NG(IBND) |
|---|
| 59 | IND = (IBND-1)*16 + IG |
|---|
| 60 | RWGT(IND) = WT(IG)/WTSM(NGM(IND)) |
|---|
| 61 | ENDDO |
|---|
| 62 | ELSE |
|---|
| 63 | DO IG = 1,NG(IBND) |
|---|
| 64 | IGCSM = IGCSM + 1 |
|---|
| 65 | IND = (IBND-1)*16 + IG |
|---|
| 66 | RWGT(IND) = _ONE_ |
|---|
| 67 | ENDDO |
|---|
| 68 | ENDIF |
|---|
| 69 | ENDDO |
|---|
| 70 | |
|---|
| 71 | ! Initialize arrays for combined Planck fraction data. |
|---|
| 72 | |
|---|
| 73 | DO IPT = 1,13 |
|---|
| 74 | DO IPR = 1, JPGPT |
|---|
| 75 | FREFA(IPR,IPT) = _ZERO_ |
|---|
| 76 | FREFADF(IPR,IPT) = _ZERO_ |
|---|
| 77 | ENDDO |
|---|
| 78 | ENDDO |
|---|
| 79 | DO IPT = 1,6 |
|---|
| 80 | DO IPR = 1, JPGPT |
|---|
| 81 | FREFB(IPR,IPT) = _ZERO_ |
|---|
| 82 | FREFBDF(IPR,IPT) = _ZERO_ |
|---|
| 83 | ENDDO |
|---|
| 84 | ENDDO |
|---|
| 85 | |
|---|
| 86 | ! Reduce g-points for relevant data in each LW spectral band. |
|---|
| 87 | |
|---|
| 88 | CALL RRTM_CMBGB1 |
|---|
| 89 | CALL RRTM_CMBGB2 |
|---|
| 90 | CALL RRTM_CMBGB3 |
|---|
| 91 | CALL RRTM_CMBGB4 |
|---|
| 92 | CALL RRTM_CMBGB5 |
|---|
| 93 | CALL RRTM_CMBGB6 |
|---|
| 94 | CALL RRTM_CMBGB7 |
|---|
| 95 | CALL RRTM_CMBGB8 |
|---|
| 96 | CALL RRTM_CMBGB9 |
|---|
| 97 | CALL RRTM_CMBGB10 |
|---|
| 98 | CALL RRTM_CMBGB11 |
|---|
| 99 | CALL RRTM_CMBGB12 |
|---|
| 100 | CALL RRTM_CMBGB13 |
|---|
| 101 | CALL RRTM_CMBGB14 |
|---|
| 102 | CALL RRTM_CMBGB15 |
|---|
| 103 | CALL RRTM_CMBGB16 |
|---|
| 104 | |
|---|
| 105 | RETURN |
|---|
| 106 | END SUBROUTINE RRTM_INIT_140GP |
|---|
