| 1 | module sfluxi_PLUTO_mod |
|---|
| 2 | |
|---|
| 3 | implicit none |
|---|
| 4 | |
|---|
| 5 | contains |
|---|
| 6 | |
|---|
| 7 | SUBROUTINE SFLUXI_PLUTO(PLEV,TLEV,DTAUI,TAUCUMI,UBARI,RSFI,WNOI, |
|---|
| 8 | * DWNI,COSBI,WBARI,NFLUXTOPI,NFLUXTOPI_nu, |
|---|
| 9 | * FMNETI,fmneti_nu,fluxupi,fluxdni,fluxupi_nu, |
|---|
| 10 | * FZEROI,TAUGSURF) |
|---|
| 11 | |
|---|
| 12 | use radinc_h, only: NTfac, NTstart, L_LEVELS, L_NSPECTI, L_NGAUSS |
|---|
| 13 | use radinc_h, only: L_NLAYRAD, L_NLEVRAD |
|---|
| 14 | use radcommon_h, only: planckir, tlimit,sigma, gweight |
|---|
| 15 | use comcstfi_mod, only: pi |
|---|
| 16 | use gfluxi_mod, only: gfluxi |
|---|
| 17 | |
|---|
| 18 | |
|---|
| 19 | implicit none |
|---|
| 20 | |
|---|
| 21 | integer NLEVRAD, L, NW, NG, NTS, NTT |
|---|
| 22 | |
|---|
| 23 | real*8 TLEV(L_LEVELS), PLEV(L_LEVELS) |
|---|
| 24 | real*8 TAUCUMI(L_LEVELS,L_NSPECTI,L_NGAUSS) |
|---|
| 25 | real*8 FMNETI(L_NLAYRAD) |
|---|
| 26 | real*8 FMNETI_NU(L_NLAYRAD,L_NSPECTI) |
|---|
| 27 | real*8 WNOI(L_NSPECTI), DWNI(L_NSPECTI) |
|---|
| 28 | real*8 DTAUI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) |
|---|
| 29 | real*8 FMUPI(L_NLEVRAD), FMDI(L_NLEVRAD) |
|---|
| 30 | real*8 COSBI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) |
|---|
| 31 | real*8 WBARI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) |
|---|
| 32 | real*8 NFLUXTOPI |
|---|
| 33 | real*8 NFLUXTOPI_nu(L_NSPECTI) |
|---|
| 34 | real*8 fluxupi_nu(L_NLAYRAD,L_NSPECTI) |
|---|
| 35 | real*8 FTOPUP |
|---|
| 36 | |
|---|
| 37 | real*8 UBARI, RSFI, TSURF, BSURF, TTOP, BTOP, TAUTOP |
|---|
| 38 | real*8 PLANCK, PLTOP |
|---|
| 39 | real*8 fluxupi(L_NLAYRAD), fluxdni(L_NLAYRAD) |
|---|
| 40 | real*8 FZEROI(L_NSPECTI) |
|---|
| 41 | real*8 taugsurf(L_NSPECTI,L_NGAUSS-1), fzero |
|---|
| 42 | |
|---|
| 43 | real*8 BSURFtest ! by RW for test |
|---|
| 44 | |
|---|
| 45 | real*8 fup_tmp(L_NSPECTI),fdn_tmp(L_NSPECTI) |
|---|
| 46 | real*8 XX,YY ! calcul intermediate |
|---|
| 47 | |
|---|
| 48 | |
|---|
| 49 | C======================================================================C |
|---|
| 50 | |
|---|
| 51 | NLEVRAD = L_NLEVRAD |
|---|
| 52 | |
|---|
| 53 | |
|---|
| 54 | C ZERO THE NET FLUXES |
|---|
| 55 | |
|---|
| 56 | NFLUXTOPI = 0.0 |
|---|
| 57 | DO NW=1,L_NSPECTI |
|---|
| 58 | NFLUXTOPI_nu(NW) = 0.0 |
|---|
| 59 | DO L=1,L_NLAYRAD |
|---|
| 60 | FLUXUPI_nu(L,NW) = 0.0 |
|---|
| 61 | FMNETI_nu(L,NW) = 0.0 |
|---|
| 62 | |
|---|
| 63 | fup_tmp(nw)=0.0 |
|---|
| 64 | fdn_tmp(nw)=0.0 |
|---|
| 65 | |
|---|
| 66 | END DO |
|---|
| 67 | END DO |
|---|
| 68 | |
|---|
| 69 | DO L=1,L_NLAYRAD |
|---|
| 70 | FMNETI(L) = 0.0 |
|---|
| 71 | FLUXUPI(L) = 0.0 |
|---|
| 72 | FLUXDNI(L) = 0.0 |
|---|
| 73 | END DO |
|---|
| 74 | |
|---|
| 75 | C WE NOW ENTER A MAJOR LOOP OVER SPECTRAL INTERVALS IN THE INFRARED |
|---|
| 76 | C TO CALCULATE THE NET FLUX IN EACH SPECTRAL INTERVAL |
|---|
| 77 | |
|---|
| 78 | TTOP = TLEV(2) |
|---|
| 79 | TSURF = TLEV(L_LEVELS) |
|---|
| 80 | !PRINT*, 'TB18 NTstart: ',NTstart,TSURF |
|---|
| 81 | NTS = int(TSURF*10.0D0)-NTstart + 1 |
|---|
| 82 | !PRINT*, 'TB18 NTS: ',NTS |
|---|
| 83 | !PRINT*, 'TB18 TLEV sfluxi: ',TLEV |
|---|
| 84 | NTT = int(TTOP *10.0D0)-NTstart +1 |
|---|
| 85 | !PRINT*, 'TB18 NTT: ',NTT |
|---|
| 86 | |
|---|
| 87 | ! if temperatures superior to 50K |
|---|
| 88 | ! NTS = TSURF*10.0D0-499 |
|---|
| 89 | ! NTT = TTOP *10.0D0-499 |
|---|
| 90 | |
|---|
| 91 | ! analyse |
|---|
| 92 | c write(*,*)'TTOP',TTOP |
|---|
| 93 | c write(*,*)'TSURF',TSURF |
|---|
| 94 | c write(*,*)'NTS',NTS |
|---|
| 95 | c write(*,*)'NTT',NTT |
|---|
| 96 | c DO L=1,L_LEVELS |
|---|
| 97 | c write(*,*)'TLEV',TLEV |
|---|
| 98 | c ENDDO |
|---|
| 99 | BSURFtest=0.0 |
|---|
| 100 | |
|---|
| 101 | DO 501 NW=1,L_NSPECTI |
|---|
| 102 | |
|---|
| 103 | C SURFACE EMISSIONS - INDEPENDENT OF GAUSS POINTS |
|---|
| 104 | BSURF = (1.-RSFI)*PLANCKIR(NW,NTS) ! interpolate for accuracy?? |
|---|
| 105 | PLTOP = PLANCKIR(NW,NTT) |
|---|
| 106 | |
|---|
| 107 | !BSURFtest=BSURFtest+BSURF*DWNI(NW) |
|---|
| 108 | !if(NW.eq.L_NSPECTI)then |
|---|
| 109 | ! print*,'eps*sigma*T^4',5.67e-8*(1.-RSFI)*TSURF**4 |
|---|
| 110 | ! print*,'BSURF in sfluxi=',pi*BSURFtest |
|---|
| 111 | !endif |
|---|
| 112 | |
|---|
| 113 | |
|---|
| 114 | C If FZEROI(NW) = 1, then the k-coefficients are zero - skip to the |
|---|
| 115 | C special Gauss point at the end. |
|---|
| 116 | |
|---|
| 117 | FZERO = FZEROI(NW) |
|---|
| 118 | IF(FZERO.ge.0.99) goto 40 |
|---|
| 119 | |
|---|
| 120 | DO NG=1,L_NGAUSS-1 |
|---|
| 121 | |
|---|
| 122 | if(TAUGSURF(NW,NG).lt. TLIMIT) then |
|---|
| 123 | fzero = fzero + (1.0-FZEROI(NW))*GWEIGHT(NG) |
|---|
| 124 | goto 30 |
|---|
| 125 | end if |
|---|
| 126 | |
|---|
| 127 | C SET UP THE UPPER AND LOWER BOUNDARY CONDITIONS ON THE IR |
|---|
| 128 | C CALCULATE THE DOWNWELLING RADIATION AT THE TOP OF THE MODEL |
|---|
| 129 | C OR THE TOP LAYER WILL COOL TO SPACE UNPHYSICALLY |
|---|
| 130 | |
|---|
| 131 | TAUTOP = DTAUI(1,NW,NG)*PLEV(2)/(PLEV(4)-PLEV(2)) |
|---|
| 132 | BTOP = (1.0-EXP(-TAUTOP/UBARI))*PLTOP |
|---|
| 133 | |
|---|
| 134 | C WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM |
|---|
| 135 | C CALL A SUBROUTINE THAT SOLVES FOR THE FLUX TERMS |
|---|
| 136 | C WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER |
|---|
| 137 | |
|---|
| 138 | CALL GFLUXI(NLEVRAD,TLEV,NW,DWNI(NW),DTAUI(1,NW,NG), |
|---|
| 139 | * TAUCUMI(1,NW,NG), |
|---|
| 140 | * WBARI(1,NW,NG),COSBI(1,NW,NG),UBARI,RSFI,BTOP, |
|---|
| 141 | * BSURF,FTOPUP,FMUPI,FMDI) |
|---|
| 142 | |
|---|
| 143 | |
|---|
| 144 | C NOW CALCULATE THE CUMULATIVE IR NET FLUX |
|---|
| 145 | XX= FTOPUP*DWNI(NW)*GWEIGHT(NG)*(1.0-FZEROI(NW)) |
|---|
| 146 | NFLUXTOPI = NFLUXTOPI+ XX |
|---|
| 147 | NFLUXTOPI_nu(NW) = NFLUXTOPI_nu(NW) + XX !same by spectral band. |
|---|
| 148 | |
|---|
| 149 | |
|---|
| 150 | DO L=1,L_NLEVRAD-1 |
|---|
| 151 | |
|---|
| 152 | C CORRECT FOR THE WAVENUMBER INTERVALS |
|---|
| 153 | YY = DWNI(NW)*GWEIGHT(NG)*(1.0-FZEROI(NW)) |
|---|
| 154 | |
|---|
| 155 | FMNETI(L) = FMNETI(L)+(FMUPI(L)-FMDI(L))* YY |
|---|
| 156 | FMNETI_nu(L,NW) = FMNETI_nu(L,NW)+(FMUPI(L)-FMDI(L))* YY !same by spectral band |
|---|
| 157 | FLUXDNI(L) = FLUXDNI(L) + FMDI(L)* YY |
|---|
| 158 | |
|---|
| 159 | FLUXUPI(L) = FLUXUPI(L) + FMUPI(L)* YY |
|---|
| 160 | FLUXUPI_nu(L,NW) = FLUXUPI_nu(L,NW) + FMUPI(L)* YY !same by spectral band. |
|---|
| 161 | END DO |
|---|
| 162 | |
|---|
| 163 | !fup_tmp(nw)=fup_tmp(nw)+FMUPI(L_NLEVRAD-1)*DWNI(NW)*GWEIGHT(NG) |
|---|
| 164 | !fdn_tmp(nw)=fdn_tmp(nw)+FMDI(L_NLEVRAD-1)*DWNI(NW)*GWEIGHT(NG) |
|---|
| 165 | !fup_tmp(nw)=fup_tmp(nw)+FMUPI(1)*DWNI(NW)*GWEIGHT(NG) |
|---|
| 166 | !fdn_tmp(nw)=fdn_tmp(nw)+FMDI(1)*DWNI(NW)*GWEIGHT(NG) |
|---|
| 167 | |
|---|
| 168 | 30 CONTINUE |
|---|
| 169 | |
|---|
| 170 | END DO !End NGAUSS LOOP |
|---|
| 171 | |
|---|
| 172 | ! print*,'-----------------------------------' |
|---|
| 173 | !print*,'FMDI(',nw,')=',FMDI(L_NLEVRAD-1) |
|---|
| 174 | !print*,'FMUPI(',nw,')=',FMUPI(L_NLEVRAD-1) |
|---|
| 175 | !print*,'DWNI(',nw,')=',DWNI(nw) |
|---|
| 176 | ! print*,'-----------------------------------' |
|---|
| 177 | |
|---|
| 178 | 40 CONTINUE |
|---|
| 179 | |
|---|
| 180 | C SPECIAL 17th Gauss point |
|---|
| 181 | |
|---|
| 182 | ! print*,'fzero for ng=17',fzero |
|---|
| 183 | |
|---|
| 184 | |
|---|
| 185 | NG = L_NGAUSS |
|---|
| 186 | |
|---|
| 187 | TAUTOP = DTAUI(1,NW,NG)*PLEV(2)/(PLEV(4)-PLEV(2)) |
|---|
| 188 | BTOP = (1.0-EXP(-TAUTOP/UBARI))*PLTOP |
|---|
| 189 | |
|---|
| 190 | C WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM |
|---|
| 191 | C CALL A SUBROUTINE THAT SOLVES FOR THE FLUX TERMS |
|---|
| 192 | C WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER |
|---|
| 193 | |
|---|
| 194 | |
|---|
| 195 | CALL GFLUXI(NLEVRAD,TLEV,NW,DWNI(NW),DTAUI(1,NW,NG), |
|---|
| 196 | * TAUCUMI(1,NW,NG), |
|---|
| 197 | * WBARI(1,NW,NG),COSBI(1,NW,NG),UBARI,RSFI,BTOP, |
|---|
| 198 | * BSURF,FTOPUP,FMUPI,FMDI) |
|---|
| 199 | |
|---|
| 200 | C NOW CALCULATE THE CUMULATIVE IR NET FLUX |
|---|
| 201 | |
|---|
| 202 | NFLUXTOPI = NFLUXTOPI+FTOPUP*DWNI(NW)*FZERO |
|---|
| 203 | NFLUXTOPI_nu(NW) = NFLUXTOPI_nu(NW)+FTOPUP*DWNI(NW)*FZERO !same by spectral band. |
|---|
| 204 | |
|---|
| 205 | DO L=1,L_NLEVRAD-1 |
|---|
| 206 | |
|---|
| 207 | C CORRECT FOR THE WAVENUMBER INTERVALS |
|---|
| 208 | |
|---|
| 209 | FLUXDNI(L) = FLUXDNI(L) + FMDI(L)*DWNI(NW)*FZERO |
|---|
| 210 | |
|---|
| 211 | XX = (FMUPI(L)-FMDI(L))*DWNI(NW)*FZERO |
|---|
| 212 | FMNETI(L) = FMNETI(L)+ XX |
|---|
| 213 | FMNETI_nu(L,NW) = FMNETI_nu(L,NW)+XX !same by spectral band. |
|---|
| 214 | |
|---|
| 215 | XX= FMUPI(L)*DWNI(NW)*FZERO |
|---|
| 216 | FLUXUPI(L) = FLUXUPI(L) + XX |
|---|
| 217 | FLUXUPI_nu(L,NW) = FLUXUPI_nu(L,NW) + XX !same by spectral band. |
|---|
| 218 | |
|---|
| 219 | END DO |
|---|
| 220 | |
|---|
| 221 | ! print*,'-----------------------------------' |
|---|
| 222 | ! print*,'nw=',nw |
|---|
| 223 | ! print*,'ng=',ng |
|---|
| 224 | ! print*,'FMDI=',FMDI(L_NLEVRAD-1) |
|---|
| 225 | ! print*,'FMUPI=',FMUPI(L_NLEVRAD-1) |
|---|
| 226 | ! print*,'-----------------------------------' |
|---|
| 227 | |
|---|
| 228 | 501 CONTINUE !End Spectral Interval LOOP |
|---|
| 229 | |
|---|
| 230 | C *** END OF MAJOR SPECTRAL INTERVAL LOOP IN THE INFRARED**** |
|---|
| 231 | |
|---|
| 232 | !print*,'-----------------------------------' |
|---|
| 233 | !print*,'gweight=',gweight |
|---|
| 234 | !print*,'FLUXDNI=',FLUXDNI(L_NLEVRAD-1) |
|---|
| 235 | !print*,'FLUXUPI=',FLUXUPI(L_NLEVRAD-1) |
|---|
| 236 | !print*,'-----------------------------------' |
|---|
| 237 | |
|---|
| 238 | !do nw=1,L_NSPECTI |
|---|
| 239 | ! print*,'fup_tmp(',nw,')=',fup_tmp(nw) |
|---|
| 240 | ! print*,'fdn_tmp(',nw,')=',fdn_tmp(nw) |
|---|
| 241 | !enddo |
|---|
| 242 | |
|---|
| 243 | |
|---|
| 244 | END SUBROUTINE SFLUXI_PLUTO |
|---|
| 245 | |
|---|
| 246 | end module sfluxi_pluto_mod |
|---|
