source: trunk/LMDZ.GENERIC/libf/phystd/sfluxi.F @ 815

      SUBROUTINE SFLUXI(PLEV,TLEV,DTAUI,TAUCUMI,UBARI,RSFI,WNOI,DWNI,
     *                  COSBI,WBARI,GWEIGHT,NFLUXTOPI,NFLUXTOPI_nu,
     *                  FMNETI,fluxupi,fluxdni,fluxupi_nu,
     *                  FZEROI,TAUGSURF)

      use radinc_h
      use radcommon_h, only: planckir, tlimit,sigma

      implicit none

#include "comcstfi.h"

      integer NLEVRAD, L, NW, NG, NTS, NTT

      real*8 TLEV(L_LEVELS), PLEV(L_LEVELS)
      real*8 TAUCUMI(L_LEVELS,L_NSPECTI,L_NGAUSS)
      real*8 FMNETI(L_NLAYRAD)
      real*8 WNOI(L_NSPECTI), DWNI(L_NSPECTI)
      real*8 DTAUI(L_NLAYRAD,L_NSPECTI,L_NGAUSS)
      real*8 FMUPI(L_NLEVRAD), FMDI(L_NLEVRAD)
      real*8 COSBI(L_NLAYRAD,L_NSPECTI,L_NGAUSS)
      real*8 WBARI(L_NLAYRAD,L_NSPECTI,L_NGAUSS)
      real*8 GWEIGHT(L_NGAUSS), NFLUXTOPI
      real*8 NFLUXTOPI_nu(L_NSPECTI)
      real*8 fluxupi_nu(L_NLAYRAD,L_NSPECTI)
      real*8 FTOPUP

      real*8 UBARI, RSFI, TSURF, BSURF, TTOP, BTOP, TAUTOP
      real*8 PLANCK, PLTOP
      real*8 fluxupi(L_NLAYRAD), fluxdni(L_NLAYRAD)
      real*8 FZEROI(L_NSPECTI)
      real*8 taugsurf(L_NSPECTI,L_NGAUSS-1), fzero

      real*8 fup_tmp(L_NSPECTI),fdn_tmp(L_NSPECTI)
      real*8 PLANCKSUM,PLANCKREF


C======================================================================C
 
      NLEVRAD = L_NLEVRAD
 

C     ZERO THE NET FLUXES
    
      NFLUXTOPI = 0.0

      DO NW=1,L_NSPECTI
        NFLUXTOPI_nu(NW) = 0.0
        DO L=1,L_NLAYRAD
           FLUXUPI_nu(L,NW) = 0.0

              fup_tmp(nw)=0.0
              fdn_tmp(nw)=0.0

        END DO
      END DO

      DO L=1,L_NLAYRAD
        FMNETI(L)  = 0.0
        FLUXUPI(L) = 0.0
        FLUXDNI(L) = 0.0
      END DO
 
C     WE NOW ENTER A MAJOR LOOP OVER SPECTRAL INTERVALS IN THE INFRARED
C     TO CALCULATE THE NET FLUX IN EACH SPECTRAL INTERVAL

      TTOP  = TLEV(2)  ! JL12 why not (1) ???
      TSURF = TLEV(L_LEVELS)

      NTS   = int(TSURF*NTfac)-NTstar+1
      NTT   = int(TTOP *NTfac)-NTstar+1
!      NTS   = TSURF*10.0D0-499
!      NTT   = TTOP *10.0D0-499

!JL12 corrects the surface planck function so that its integral is equal to sigma Tsurf^4
!JL12   this ensure that no flux is lost due to:
!JL12          -truncation of the planck function at high/low wavenumber
!JL12          -numerical error during first spectral integration
!JL12          -discrepancy between Tsurf and NTS/NTfac
      PLANCKSUM=0.d0
      PLANCKREF=TSURF*TSURF
      PLANCKREF=sigma*PLANCKREF*PLANCKREF
      DO NW=1,L_NSPECTI
         PLANCKSUM=PLANCKSUM+PLANCKIR(NW,NTS)*DWNI(NW)
      ENDDO
      PLANCKSUM=PLANCKREF/(PLANCKSUM*Pi)
!JL12

      DO 501 NW=1,L_NSPECTI

C       SURFACE EMISSIONS - INDEPENDENT OF GAUSS POINTS
        BSURF = (1.-RSFI)*PLANCKIR(NW,NTS)*PLANCKSUM !JL12 plancksum see above
        PLTOP = PLANCKIR(NW,NTT)

C  If FZEROI(NW) = 1, then the k-coefficients are zero - skip to the
C  special Gauss point at the end.
 
        FZERO = FZEROI(NW)
        IF(FZERO.ge.0.99) goto 40
 
        DO NG=1,L_NGAUSS-1
         
          if(TAUGSURF(NW,NG).lt. TLIMIT) then
            fzero = fzero + (1.0-FZEROI(NW))*GWEIGHT(NG)
            goto 30
          end if

C         SET UP THE UPPER AND LOWER BOUNDARY CONDITIONS ON THE IR
C         CALCULATE THE DOWNWELLING RADIATION AT THE TOP OF THE MODEL
C         OR THE TOP LAYER WILL COOL TO SPACE UNPHYSICALLY
 
          TAUTOP = DTAUI(1,NW,NG)*PLEV(2)/(PLEV(4)-PLEV(2))
          BTOP   = (1.0-EXP(-TAUTOP/UBARI))*PLTOP
 
C         WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM
C         CALL A SUBROUTINE THAT SOLVES  FOR THE FLUX TERMS
C         WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER 
          
          CALL GFLUXI(NLEVRAD,TLEV,NW,DWNI(NW),DTAUI(1,NW,NG),
     *                TAUCUMI(1,NW,NG),
     *                WBARI(1,NW,NG),COSBI(1,NW,NG),UBARI,RSFI,BTOP,
     *                BSURF,FTOPUP,FMUPI,FMDI)



C         NOW CALCULATE THE CUMULATIVE IR NET FLUX

          NFLUXTOPI = NFLUXTOPI+FTOPUP*DWNI(NW)*GWEIGHT(NG)*
     *                           (1.0-FZEROI(NW))

c         and same thing by spectral band... (RDW)
          NFLUXTOPI_nu(NW) = NFLUXTOPI_nu(NW)
     *      +FTOPUP*DWNI(NW)*GWEIGHT(NG)*(1.0-FZEROI(NW))


          DO L=1,L_NLEVRAD-1

C           CORRECT FOR THE WAVENUMBER INTERVALS

            FMNETI(L)  = FMNETI(L)+(FMUPI(L)-FMDI(L))*DWNI(NW)*
     *                              GWEIGHT(NG)*(1.0-FZEROI(NW))
            FLUXUPI(L) = FLUXUPI(L) + FMUPI(L)*DWNI(NW)*GWEIGHT(NG)*
     *                                (1.0-FZEROI(NW))
            FLUXDNI(L) = FLUXDNI(L) + FMDI(L)*DWNI(NW)*GWEIGHT(NG)*
     *                                (1.0-FZEROI(NW))

c         and same thing by spectral band... (RW)
            FLUXUPI_nu(L,NW) = FLUXUPI_nu(L,NW) + 
     *                FMUPI(L)*DWNI(NW)*GWEIGHT(NG)*(1.0-FZEROI(NW))

          END DO

   30     CONTINUE

       END DO       !End NGAUSS LOOP

   40  CONTINUE

C      SPECIAL 17th Gauss point

       NG     = L_NGAUSS

       TAUTOP = DTAUI(1,NW,NG)*PLEV(2)/(PLEV(4)-PLEV(2))
       BTOP   = (1.0-EXP(-TAUTOP/UBARI))*PLTOP

C      WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM
C      CALL A SUBROUTINE THAT SOLVES  FOR THE FLUX TERMS
C      WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER 


       CALL GFLUXI(NLEVRAD,TLEV,NW,DWNI(NW),DTAUI(1,NW,NG),
     *                TAUCUMI(1,NW,NG),
     *                WBARI(1,NW,NG),COSBI(1,NW,NG),UBARI,RSFI,BTOP,
     *                BSURF,FTOPUP,FMUPI,FMDI)
 
C      NOW CALCULATE THE CUMULATIVE IR NET FLUX

       NFLUXTOPI = NFLUXTOPI+FTOPUP*DWNI(NW)*FZERO

c         and same thing by spectral band... (RW)
          NFLUXTOPI_nu(NW) = NFLUXTOPI_nu(NW)
     *      +FTOPUP*DWNI(NW)*FZERO

       DO L=1,L_NLEVRAD-1

C        CORRECT FOR THE WAVENUMBER INTERVALS

         FMNETI(L)  = FMNETI(L)+(FMUPI(L)-FMDI(L))*DWNI(NW)*FZERO
         FLUXUPI(L) = FLUXUPI(L) + FMUPI(L)*DWNI(NW)*FZERO
         FLUXDNI(L) = FLUXDNI(L) + FMDI(L)*DWNI(NW)*FZERO

c         and same thing by spectral band... (RW)
         FLUXUPI_nu(L,NW) = FLUXUPI_nu(L,NW) + FMUPI(L)*DWNI(NW)*FZERO

       END DO

  501 CONTINUE      !End Spectral Interval LOOP

C *** END OF MAJOR SPECTRAL INTERVAL LOOP IN THE INFRARED****

      RETURN
      END