source: trunk/libf/phytitan/sfluxv.F @ 21

      SUBROUTINE SFLUXV(IPRINT,IG,dist_sol)

      IMPLICIT NONE

#include "dimensions.h"
#include "dimphy.h"
#include "comorbit.h"

      INTEGER NLAYER,NLEVEL,NSPECV,NSPC1V
      PARAMETER (NLAYER=llm,NLEVEL=NLAYER+1)
      PARAMETER (NSPECV=24,NSPC1V=25)
      INTEGER IG,IPRINT,NT,NTERM(NSPECV),J,K

      REAL FUW(NLEVEL),FDW(NLEVEL)
      REAL DT0(NLAYER),T0(NLEVEL),WB0(NLAYER),CO0(NLAYER)
      REAL BTOP, BSURF
      REAL ATERM(4,NSPECV),BTERM(4,NSPECV)
      REAL PEXPON(NSPECV), SOLARF(NSPECV)
      REAL  DTAUV(klon,NLAYER,NSPECV,4)
     &     ,TAUV (klon,NLEVEL,NSPECV,4)
     &     ,WBARV(klon,NLAYER,NSPECV,4) 
     &     ,COSBV(klon,NLAYER,NSPECV,4)
      REAL BWNV(NSPC1V),WNOV(NSPECV)
     &     ,DWNV(NSPECV),WLNV(NSPECV)
      REAL  FNETV(klon,NLEVEL),     
     &      FUPV(klon,NLEVEL,NSPECV),
     &      FDV(klon,NLEVEL,NSPECV),
     &      FMNETV(klon,NLEVEL),
     &      FMUPV(NLEVEL),FMDV(NLEVEL)
      REAL CSUBP,RSFI,RSFV,F0PI
      REAL UBARI,UBARV,UBAR0

      real dist_sol

      COMMON /VISGAS/SOLARF,NTERM,PEXPON,
     &         ATERM,BTERM

      COMMON /OPTICV/  DTAUV
     &                ,TAUV 
     &                ,WBARV 
     &                ,COSBV

      COMMON /SPECTV/ BWNV,WNOV
     &               ,DWNV,WLNV

      COMMON /FLUXvV/ FNETV,     
     &               FUPV,
     &               FDV,
     &               FMNETV

      COMMON /PLANT/ CSUBP,RSFI,RSFV,F0PI
      COMMON /UBARED/ UBARI,UBARV,UBAR0


* ON NE FAIT PAS LE CALCUL POUR TOUS LES IG EN MEME TEMPS
* IG EST EN ARGUMENT...et SFLUXV EST APPELLEE NGRIDMX FOIS!

C ZERO THE NET FLUXES
      DO 212 J=1,NLEVEL
      FNETV(ig,J)=-0.
      FMNETV(ig,J)=-0.
  212 CONTINUE
C
C WE NOW ENTER A MAJOR LOOP OVER SPECRAL INTERVALS IN THE VISIBLE
C AND OVER THE HORIZONTAL GRIDS
C TO CALCULATE THE NET FLUX IN EACH SPECTRAL INTERVAL
C
C ***************************************************************


      DO 500 K=1,NSPECV          ! #2
C ZERO THE SPECTRAL FLUXES IN ANTCIPATION OF SUMMING OVER NTERMS

       DO 214 J=1,NLEVEL         ! #3
       FUPV(ig,J,K)=0.
       FDV(ig,J,K)=0.
 214   CONTINUE
C
C SET UP THE UPPER AND LOWER BOUNDARY CONDITIONS ON THE VISIBLE
      F0PI=SOLARF(K)*(p_elips/dist_sol)**2.
      BTOP=0.0
C
C LOOP OVER THE NTERMS BEGINING HERE
      DO 912 NT=1,NTERM(K)
      BSURF=0.+ RSFV*UBAR0*F0PI*EXP(-TAUV(ig,NLEVEL,K,NT)/UBAR0)
C
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
C
C FUW AND FDW ARE WORKING FLUX ARRAYS THAT WILL BE USED TO
C RETURN FLUXES FOR A GIVEN NT
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
C  USE DT0,T0,WB0,CO0 INSTEAD OF DTAUV(ig,1,K,NT)..etc...

       DO  J=1,NLAYER        
             DT0(J)=DTAUV(ig,J,K,NT)
             T0(J) =TAUV(ig,J,K,NT)
             WB0(J)=WBARV(ig,J,K,NT)
             CO0(J)=COSBV(ig,J,K,NT)
       ENDDO

             T0(NLEVEL)=TAUV(ig,NLEVEL,K,NT)

c       PRINT*,'entree gfluxv #: ',ig,K
c        write(*,*) (DT0(J),J=1,NLAYER)
c        print*,'---'
c        write(*,*) (T0(J),J=1,NLEVEL)
c        print*,'---'
c        write(*,*) (WB0(J),J=1,NLAYER)
c        print*,'---'
c        write(*,*) (CO0(J),J=1,NLAYER)
c        print*,'UBAR0 ',UBAR0
c      print*,NLEVEL,WNOV(K),F0PI,RSFV,BTOP,BSURF
       FUW = 0.0
       FDW = 0.0
       FMUPV=0.0
       FMDV= 0.0
       
      CALL GFLUXV(NLEVEL,WNOV(K),DT0,T0,
     & WB0,CO0,F0PI,RSFV,BTOP,BSURF,FUW,FDW,FMUPV,
     &    FMDV,IPRINT)
c       PRINT*,'sortie gfluxv #: ',ig,K
c        print*,'UBAR0 ',UBAR0

C NOW CALCULTE THE CUMULATIVE VISIBLE NET FLUX

             DO 300 J=1,NLEVEL         !<------------
      FMNETV(ig,J)=FMNETV(ig,J)+( FMUPV(J)-FMDV(J) )*ATERM(NT,K)
      FNETV(ig,J)=FNETV(ig,J)+( FUW(J)-FDW(J) )*ATERM(NT,K)

C AND THE SPECTRAL FLUXES SUMMED OVER THE NTERMS
      FUPV(ig,J,K)=FUPV(ig,J,K)+FUW(J)*ATERM(NT,K)
      FDV(ig,J,K)=FDV(ig,J,K)+FDW(J)*ATERM(NT,K)
  300         CONTINUE                !<--------------
C
C
  912 CONTINUE
  500 CONTINUE

C *** END OF MAJOR SPECTRAL INTERVAL LOOP IN THE VISIBLE*****
      RETURN
      END