[3880] | 1 | !*************************************************************************** |
---|
| 2 | SUBROUTINE RRTM_INIT_140GP(DIRECTORY) |
---|
| 3 | !*************************************************************************** |
---|
| 4 | ! Reformatted for F90 by JJMorcrette, ECMWF, 980714 |
---|
| 5 | |
---|
| 6 | ! JJMorcrette 20110613 flexible number of g-points |
---|
| 7 | |
---|
| 8 | ! Parameters |
---|
| 9 | USE PARKIND1 ,ONLY : JPIM ,JPRB |
---|
| 10 | USE YOMHOOK ,ONLY : LHOOK, DR_HOOK |
---|
| 11 | |
---|
| 12 | USE PARRRTM , ONLY : JPBAND ,JPG |
---|
| 13 | USE YOERRTM , ONLY : JPGPT |
---|
| 14 | USE YOERRTWN , ONLY : NG |
---|
| 15 | USE YOERRTFTR, ONLY : NGC ,NGN ,NGM , WT |
---|
| 16 | ! Output |
---|
| 17 | USE YOERRTBG2, ONLY : CORR1 ,CORR2 |
---|
| 18 | USE YOERRTRWT, ONLY : FREFA ,FREFB ,FREFADF ,FREFBDF ,RWGT |
---|
| 19 | !USE YOMLUN , ONLY : NULOUT |
---|
| 20 | |
---|
| 21 | IMPLICIT NONE |
---|
| 22 | |
---|
| 23 | CHARACTER(LEN=*), INTENT(IN) :: DIRECTORY |
---|
| 24 | |
---|
| 25 | REAL(KIND=JPRB) :: ZWTSM(JPG) |
---|
| 26 | |
---|
| 27 | INTEGER(KIND=JPIM) :: I, IBND, IG, IGC, IGCSM, IND, IPR, IPRSM, IPT |
---|
| 28 | |
---|
| 29 | REAL(KIND=JPRB) :: ZFP, ZRTFP, ZWTSUM |
---|
| 30 | REAL(KIND=JPRB) :: ZHOOK_HANDLE |
---|
| 31 | |
---|
| 32 | !#include "surrtmcf.intfb.h" |
---|
| 33 | #include "surrtftr.intfb.h" |
---|
| 34 | |
---|
| 35 | #include "rrtm_kgb1.intfb.h" |
---|
| 36 | #include "rrtm_kgb10.intfb.h" |
---|
| 37 | #include "rrtm_kgb11.intfb.h" |
---|
| 38 | #include "rrtm_kgb12.intfb.h" |
---|
| 39 | #include "rrtm_kgb13.intfb.h" |
---|
| 40 | #include "rrtm_kgb14.intfb.h" |
---|
| 41 | #include "rrtm_kgb15.intfb.h" |
---|
| 42 | #include "rrtm_kgb16.intfb.h" |
---|
| 43 | #include "rrtm_kgb2.intfb.h" |
---|
| 44 | #include "rrtm_kgb3.intfb.h" |
---|
| 45 | #include "rrtm_kgb4.intfb.h" |
---|
| 46 | #include "rrtm_kgb5.intfb.h" |
---|
| 47 | #include "rrtm_kgb6.intfb.h" |
---|
| 48 | #include "rrtm_kgb7.intfb.h" |
---|
| 49 | #include "rrtm_kgb8.intfb.h" |
---|
| 50 | #include "rrtm_kgb9.intfb.h" |
---|
| 51 | |
---|
| 52 | #include "rrtm_cmbgb1.intfb.h" |
---|
| 53 | #include "rrtm_cmbgb10.intfb.h" |
---|
| 54 | #include "rrtm_cmbgb11.intfb.h" |
---|
| 55 | #include "rrtm_cmbgb12.intfb.h" |
---|
| 56 | #include "rrtm_cmbgb13.intfb.h" |
---|
| 57 | #include "rrtm_cmbgb14.intfb.h" |
---|
| 58 | #include "rrtm_cmbgb15.intfb.h" |
---|
| 59 | #include "rrtm_cmbgb16.intfb.h" |
---|
| 60 | #include "rrtm_cmbgb2.intfb.h" |
---|
| 61 | #include "rrtm_cmbgb3.intfb.h" |
---|
| 62 | #include "rrtm_cmbgb4.intfb.h" |
---|
| 63 | #include "rrtm_cmbgb5.intfb.h" |
---|
| 64 | #include "rrtm_cmbgb6.intfb.h" |
---|
| 65 | #include "rrtm_cmbgb7.intfb.h" |
---|
| 66 | #include "rrtm_cmbgb8.intfb.h" |
---|
| 67 | #include "rrtm_cmbgb9.intfb.h" |
---|
| 68 | |
---|
| 69 | IF (LHOOK) CALL DR_HOOK('RRTM_INIT_140GP',0,ZHOOK_HANDLE) |
---|
| 70 | |
---|
| 71 | !CALL SURRTMCF |
---|
| 72 | CALL SURRTFTR |
---|
| 73 | |
---|
| 74 | ! Read the absorption-related coefficients over the 16 x 16 g-points |
---|
| 75 | |
---|
| 76 | CALL RRTM_KGB1(DIRECTORY) |
---|
| 77 | CALL RRTM_KGB2 |
---|
| 78 | CALL RRTM_KGB3 |
---|
| 79 | CALL RRTM_KGB4 |
---|
| 80 | CALL RRTM_KGB5 |
---|
| 81 | CALL RRTM_KGB6 |
---|
| 82 | CALL RRTM_KGB7 |
---|
| 83 | CALL RRTM_KGB8 |
---|
| 84 | CALL RRTM_KGB9 |
---|
| 85 | CALL RRTM_KGB10 |
---|
| 86 | CALL RRTM_KGB11 |
---|
| 87 | CALL RRTM_KGB12 |
---|
| 88 | CALL RRTM_KGB13 |
---|
| 89 | CALL RRTM_KGB14 |
---|
| 90 | CALL RRTM_KGB15 |
---|
| 91 | CALL RRTM_KGB16 |
---|
| 92 | |
---|
| 93 | ! Calculate lookup tables for functions needed in routine TAUMOL (TAUGB2) |
---|
| 94 | |
---|
| 95 | CORR1(0) = 1.0_JPRB |
---|
| 96 | CORR1(200) = 1.0_JPRB |
---|
| 97 | CORR2(0) = 1.0_JPRB |
---|
| 98 | CORR2(200) = 1.0_JPRB |
---|
| 99 | DO I = 1,199 |
---|
| 100 | ZFP = 0.005_JPRB*REAL(I) |
---|
| 101 | ZRTFP = SQRT(ZFP) |
---|
| 102 | CORR1(I) = ZRTFP/ZFP |
---|
| 103 | CORR2(I) = (1.0_JPRB-ZRTFP)/(1.0_JPRB-ZFP) |
---|
| 104 | ENDDO |
---|
| 105 | |
---|
| 106 | ! Perform g-point reduction from 16 per band (256 total points) to |
---|
| 107 | ! a band dependant number (140 total points) for all absorption |
---|
| 108 | ! coefficient input data and Planck fraction input data. |
---|
| 109 | ! Compute relative weighting for new g-point combinations. |
---|
| 110 | |
---|
| 111 | IGCSM = 0 |
---|
| 112 | !WRITE(NULOUT,9001) JPBAND,JPG,JPGPT |
---|
| 113 | 9001 format(1x,'rrtm_init JPBAND=',I3,' JPG=',I3,' JPGPT=',I3) |
---|
| 114 | DO IBND = 1,JPBAND |
---|
| 115 | IPRSM = 0 |
---|
| 116 | ! WRITE(NULOUT,9002) IBND,NGC(IBND) |
---|
| 117 | 9002 format(1x,'rrtm_init NGC(',I3,')=',I3) |
---|
| 118 | IF (NGC(IBND) < 16) THEN |
---|
| 119 | DO IGC = 1,NGC(IBND) |
---|
| 120 | IGCSM = IGCSM + 1 |
---|
| 121 | ZWTSUM = 0.0_JPRB |
---|
| 122 | ! WRITE(NULOUT,9003) IGC,IGCSM,NGN(IGCSM) |
---|
| 123 | 9003 format(1x,'rrtm_init IGC=',I3,' NGN(',I3,')=',I3) |
---|
| 124 | DO IPR = 1, NGN(IGCSM) |
---|
| 125 | IPRSM = IPRSM + 1 |
---|
| 126 | ! WRITE(NULOUT,9004) IPR,IPRSM,WT(IPRSM) |
---|
| 127 | 9004 format(1x,'rrtm_init IPR=',I3,' WT(',I3,')=',E14.7) |
---|
| 128 | ZWTSUM = ZWTSUM + WT(IPRSM) |
---|
| 129 | ENDDO |
---|
| 130 | ! WRITE(NULOUT,9005) IGC,ZWTSUM |
---|
| 131 | 9005 format(1x,'rrtm_init WTSM(',I3,')=',E14.7) |
---|
| 132 | ZWTSM(IGC) = ZWTSUM |
---|
| 133 | ENDDO |
---|
| 134 | |
---|
| 135 | ! WRITE(NULOUT,9006) IBND,NG(IBND) |
---|
| 136 | 9006 format(1x,'rrtm_init NG(',I3,')=',I3) |
---|
| 137 | DO IG = 1,NG(IBND) |
---|
| 138 | IND = (IBND-1)*16 + IG |
---|
| 139 | RWGT(IND) = WT(IG)/ZWTSM(NGM(IND)) |
---|
| 140 | ! WRITE(NULOUT,9007) IND,NGM(IND),IG,WT(IG),ZWTSM(NGM(IND)),IND,RWGT(IND) |
---|
| 141 | 9007 format(1x,'rrtm_init NGM(',I3,')=',I3,' WT(',I3,')=',E13.7,' WTSM=',E13.7,' RWGT(',I3,')=',E13.7) |
---|
| 142 | ENDDO |
---|
| 143 | ELSE |
---|
| 144 | DO IG = 1,NG(IBND) |
---|
| 145 | IGCSM = IGCSM + 1 |
---|
| 146 | IND = (IBND-1)*16 + IG |
---|
| 147 | RWGT(IND) = 1.0_JPRB |
---|
| 148 | ENDDO |
---|
| 149 | ENDIF |
---|
| 150 | ENDDO |
---|
| 151 | |
---|
| 152 | ! Initialize arrays for combined Planck fraction data. |
---|
| 153 | |
---|
| 154 | DO IPT = 1,13 |
---|
| 155 | DO IPR = 1, JPGPT |
---|
| 156 | FREFA(IPR,IPT) = 0.0_JPRB |
---|
| 157 | FREFADF(IPR,IPT) = 0.0_JPRB |
---|
| 158 | ENDDO |
---|
| 159 | ENDDO |
---|
| 160 | DO IPT = 1,6 |
---|
| 161 | DO IPR = 1, JPGPT |
---|
| 162 | FREFB(IPR,IPT) = 0.0_JPRB |
---|
| 163 | FREFBDF(IPR,IPT) = 0.0_JPRB |
---|
| 164 | ENDDO |
---|
| 165 | ENDDO |
---|
| 166 | |
---|
| 167 | ! Reduce g-points for relevant data in each LW spectral band. |
---|
| 168 | |
---|
| 169 | CALL RRTM_CMBGB1 |
---|
| 170 | CALL RRTM_CMBGB2 |
---|
| 171 | CALL RRTM_CMBGB3 |
---|
| 172 | CALL RRTM_CMBGB4 |
---|
| 173 | CALL RRTM_CMBGB5 |
---|
| 174 | CALL RRTM_CMBGB6 |
---|
| 175 | CALL RRTM_CMBGB7 |
---|
| 176 | CALL RRTM_CMBGB8 |
---|
| 177 | CALL RRTM_CMBGB9 |
---|
| 178 | CALL RRTM_CMBGB10 |
---|
| 179 | CALL RRTM_CMBGB11 |
---|
| 180 | CALL RRTM_CMBGB12 |
---|
| 181 | CALL RRTM_CMBGB13 |
---|
| 182 | CALL RRTM_CMBGB14 |
---|
| 183 | CALL RRTM_CMBGB15 |
---|
| 184 | CALL RRTM_CMBGB16 |
---|
| 185 | |
---|
| 186 | IF (LHOOK) CALL DR_HOOK('RRTM_INIT_140GP',1,ZHOOK_HANDLE) |
---|
| 187 | END SUBROUTINE RRTM_INIT_140GP |
---|